From 40bc4cb77a52ff50c265d90f136e7e513f052414 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 30 Oct 2009 16:27:55 +0000 Subject: [PATCH] remove dead examples svn: r16480 --- .../tests/typed-scheme/660-examples/hw02.scm | 238 ------------ .../tests/typed-scheme/660-examples/hw03.scm | 275 -------------- .../tests/typed-scheme/660-examples/hw04.scm | 349 ------------------ .../tests/typed-scheme/660-examples/hw05.scm | 222 ----------- .../tests/typed-scheme/660-examples/slow.ss | 25 -- .../typed-scheme/660-examples/support.ss | 21 -- 6 files changed, 1130 deletions(-) delete mode 100644 collects/tests/typed-scheme/660-examples/hw02.scm delete mode 100644 collects/tests/typed-scheme/660-examples/hw03.scm delete mode 100644 collects/tests/typed-scheme/660-examples/hw04.scm delete mode 100644 collects/tests/typed-scheme/660-examples/hw05.scm delete mode 100644 collects/tests/typed-scheme/660-examples/slow.ss delete mode 100644 collects/tests/typed-scheme/660-examples/support.ss diff --git a/collects/tests/typed-scheme/660-examples/hw02.scm b/collects/tests/typed-scheme/660-examples/hw02.scm deleted file mode 100644 index 3e3a17b5c6..0000000000 --- a/collects/tests/typed-scheme/660-examples/hw02.scm +++ /dev/null @@ -1,238 +0,0 @@ -#reader (planet "typed-reader.ss" ("plt" "typed-scheme.plt")) -(module hw02 "../../typed-scheme.ss" - (require "support.ss") - ;;; -------------------------------------------------------------------- - ;;; Question 1 - - ;; list-product : (list-of number) (list-of number) -> number - ;; computes the dot-product of two lists (as vector representations) - ;; (Assumes the two inputs are of equal length) - (define: (list-product [l1 : (Listof number)] [l2 : (Listof number)]) : number - (foldl #{+ :: (number number -> number)} 0 (map #{* :: (number number -> number)} l1 l2))) - - ;; tests - (test (list-product '(1 2 3) '(4 5 6)) => 32) - (test (list-product '() '()) => 0) - - - ;;; -------------------------------------------------------------------- - ;;; Question 2 - - #| - - ::= + - | - - | - - ::= * - | / - | - - ::= - | + - | - - | ( ) - - In the rules for , note that any number of unary +/- - operators can be used, and that the resulting grammar is not - ambiguous since they are put in yet another level below (they - have higher precedence than the binary operators). - -|# - - - ;;; -------------------------------------------------------------------- - ;;; Question 3 - - ;; [3a] - (define-type BINTREE - [Node (l BINTREE) (r BINTREE)] - [Leaf (n number)]) - - ;; used for tests: - (define: 1234-tree : BINTREE - (Node (Node (Leaf 1) (Leaf 2)) - (Node (Leaf 3) (Leaf 4)))) - (define: 528-tree : BINTREE (Node (Leaf 5) (Node (Leaf 2) (Leaf 8)))) - #;(provide (all-defined)) - #| [3b] BNF: - - ::= | - - ::= (Node ) - - ::= (Leaf ) - -|# - - ;; [3c] - - ;; tree-reduce : BINTREE (num num -> num) -> num - ;; Reduces a BINTREE to a number by descending recursively and combining - ;; results with `op'. - (define: (tree-reduce [tree : BINTREE] [op : (number number -> number)]) : number - (cases tree - [(Node l r) (op (tree-reduce l op) (tree-reduce r op))] - [(Leaf n) n])) - ;; tests: - (test 10 <= (tree-reduce 1234-tree +)) - (test 10 <= (tree-reduce (Leaf 10) +)) - (test 24 <= (tree-reduce 1234-tree *)) - - ;; tree-min : BINTREE -> num - ;; Finds the minimum number in a BINTREE. - (define: (tree-min [tree : BINTREE]) : number - (tree-reduce tree min)) - ;; tests: - (test 1 <= (tree-min 1234-tree)) - (test 1 <= (tree-min (Leaf 1))) - - ;; tree-min : BINTREE -> num - ;; Finds the maximum number in a BINTREE. - (define: (tree-max [tree : BINTREE]) : number - (tree-reduce tree max)) - ;; tests: - (test 4 <= (tree-max 1234-tree)) - (test 1 <= (tree-max (Leaf 1))) - - ;; tree-sorted? : BINTREE -> bool - ;; Tests whether the tree is sorted or not. - (define: (tree-sorted? [tree : BINTREE]) : boolean - (cases tree - [(Node l r) (and (tree-sorted? l) - (tree-sorted? r) - (<= (tree-max l) (tree-min r)))] - [(Leaf n) #t])) - ;; tests: - (test (tree-sorted? 1234-tree)) - (test (tree-sorted? (Leaf 1))) - (test (not (tree-sorted? 528-tree))) - #| - #| [3d] - - Say that the cost function is cost(n) for a tree with n leaves, and - that we're given a balanced tree of 32 leaves. We have: - - cost(32) = 16 ; for finding the max the left side - + 16 ; for finding the min the right side - + cost(16) ; for the recursive call on the left - + cost(16) ; for the recursive call on the right - + 1 ; some constant for the `and' and the `<' - - In general, we can drop the last one since it doesn't matter and get: - - cost(n) = 2*(n/2) + 2*cost(n/2) = n + 2*cost(n/2) - - and - - cost(1) = 1 - - Continueing with the case of 32: - - cost(32) = 32 + 2*cost(16) - = 32 + 2*(16 + 2*cost(8)) - = 32 + 32 + 4*cost(8) - = 32 + 32 + 32 + 8*cost(4) - = 32 + 32 + 32 + 32 + 16*cost(2) - = 32 + 32 + 32 + 32 + 32 + 32*cost(1) - = 32 + 32 + 32 + 32 + 32 + 32 - - So the total cost for n leaves is n*log2(n). - -|# - - ;; 3e - - ;; tree-sorted*? : BINTREE -> bool - ;; Tests whether the tree is sorted or not in linear time. - ;; -- The trick is to check for sortedness by recursively walking the - ;; tree and remembering the last value we have seen and making sure - ;; that new leaves are always bigger. The return value of the helper - ;; is either the right-most value if it is sorted, or #f if not. - (define (tree-sorted*? tree) - ;; `and' is used to turn the result into a proper boolean - (and (sorted*?-helper - tree - (- (left-most-value tree) 1)) ; initialize a last value - #t)) - - ;; left-most-value : BINTREE -> num - ;; Finds the left-most value in a BINTREE. - (define (left-most-value tree) - (cases tree - [(Leaf n) n] - [(Node l r) (left-most-value l)])) - - ;; sorted*?-helper : BINTREE num -> bool-or-num - ;; Helper for the above -- checks that the given tree is sorted and - ;; bigger than the given number, and returns the right-most number if it - ;; is sorted. - (define (sorted*?-helper tree last) - (cases tree - [(Leaf n) - (and (< last n) n)] - [(Node l r) - (let ([left-last (sorted*?-helper l last)]) - (and left-last (sorted*?-helper r left-last)))])) - - ;; tests: - (test (tree-sorted*? 1234-tree)) - (test (tree-sorted*? (Leaf 1))) - (test (not (tree-sorted*? 528-tree))) - - - ;;; -------------------------------------------------------------------- - ;;; Question 4 - - ;; tree-map : (num -> num) BINTREE -> BINTREE - ;; Maps the given function recursively over the given tree, returning a - ;; tree of the results with the same shape. - (define (tree-map f tree) - (cases tree - [(Leaf n) (Leaf (f n))] - [(Node l r) (Node (tree-map f l) (tree-map f r))])) - - ;; tests - (test (tree-map add1 (Node (Leaf 1) (Node (Leaf 2) (Leaf 3)))) - => (Node (Leaf 2) (Node (Leaf 3) (Leaf 4)))) - (test (tree-map add1 1234-tree) - => (Node (Node (Leaf 2) (Leaf 3)) (Node (Leaf 4) (Leaf 5)))) - (test (tree-map add1 (Leaf 1)) - => (Leaf 2)) - - - ;;; -------------------------------------------------------------------- - ;;; Question 5 - - ;; tree-insert : BINTREE num -> BINTREE - (define (tree-insert tree n) - (cases tree - [(Leaf m) (if (< n m) - (Node (Leaf n) tree) - (Node tree (Leaf n)))] - [(Node l r) (if (< n (tree-max l)) - (Node (tree-insert l n) r) - (Node l (tree-insert r n)))])) - - ;; tests: - (test (tree-sorted? - (tree-insert (Node (Leaf 2) (Node (Leaf 4) (Leaf 6))) - 3))) - (test (tree-sorted? (tree-insert 1234-tree 0))) - (test (tree-sorted? (tree-insert 1234-tree 5))) - - - ;;; -------------------------------------------------------------------- - ;;; Question 6 - - #| - - The problem is that we need to keep both flattened copies in memory - for the comparison. This means that if we have two big trees, say - 200MB each, then during the comparison we will need to have 800MB of - RAM! The solution for this is very hard for now, but later in the - course we will see one easy way to solve it. - -|#|# - - ) diff --git a/collects/tests/typed-scheme/660-examples/hw03.scm b/collects/tests/typed-scheme/660-examples/hw03.scm deleted file mode 100644 index e0c0cb4325..0000000000 --- a/collects/tests/typed-scheme/660-examples/hw03.scm +++ /dev/null @@ -1,275 +0,0 @@ -#reader (planet "typed-reader.ss" ("plt" "typed-scheme.plt")) -(module hw03 "../../typed-scheme.ss" - - (require "support.ss") - - #| This is the updated Algae BNF definition: - ::= - | { + ... } - | { - ... } - | { * ... } - | { / ... } - | { = } - | { < } - | { <= } - | { if } - | { with { } } - | -|# - - (define-type ALGAE - [Num (n number)] - [Add (args (list-of ALGAE))] - ;; note how Sub & Div match the corresponding BNF derivation - [Sub (fst ALGAE) (args (list-of ALGAE))] - [Mul (args (list-of ALGAE))] - [Div (fst ALGAE) (args (list-of ALGAE))] - [Eql (lhs ALGAE) (rhs ALGAE)] - [Less (lhs ALGAE) (rhs ALGAE)] - [LessEql (lhs ALGAE) (rhs ALGAE)] - [If (cond-expr ALGAE) (then-expr ALGAE) (else-expr ALGAE)] - [Id (name symbol)] - [With (name symbol) (named ALGAE) (body ALGAE)]) - - - ;; parse-sexpr : s-expr -> ALGAE - #;(define: (parse-sexpr [sexpr : Sexp]) : ALGAE - (cond - [(number? sexpr) (Num sexpr)] - [(symbol? sexpr) (Id sexpr)] - ;; new code (needed because not doesn't work) - [(null? sexpr) (error 'parse-sexpr "bad syntax in ~s" sexpr)] - ;; end new code - ;; these next two have the horrid and trick. - [(and (list? sexpr) (not (null? sexpr)) - (eq? 'with (first sexpr)) - (let ([s (second sexpr)]) - (if (list? s) - (if (= 2 (length s)) - (let ([sym (first s)]) - (if (symbol? sym) - (With sym - (parse-sexpr (second s)) - (parse-sexpr (third sexpr))) - (error 'parse-sexpr "bad `with' syntax"))) - (error 'parse-sexpr "bad `with' syntax")) - (error 'parse-sexpr "bad `with' syntax"))))] - [(and (list? sexpr) (not (null? sexpr)) - (let ([subs (map parse-sexpr (rest sexpr))]) - (case (first sexpr) - [(+) (Add subs)] - [(-) (if (null? subs) - (error 'parse-sexpr "need at least one arg for `-'") - (Sub (first subs) (rest subs)))] - [(*) (Mul subs)] - [(/) (if (null? subs) - (error 'parse-sexpr "need at least one arg for `/'") - (Div (first subs) (rest subs)))] - [(=) (if (= 2 (length subs)) - (Eql (first subs) (second subs)) - (error 'parse-sexpr "need two args for `='"))] - [(<) (if (= 2 (length subs)) - (Less (first subs) (second subs)) - (error 'parse-sexpr "need two args for `<'"))] - [(<=) (if (= 2 (length subs)) - (LessEql (first subs) (second subs)) - (error 'parse-sexpr "need two args for `<='"))] - [(if) (if (= 3 (length subs)) - (If (first subs) (second subs) (third subs)) - (error 'parse-sexpr "need three exprs for `if'"))] - [else (error 'parse-sexpr "don't know about ~s" - (first sexpr))])))] - [else (error 'parse-sexpr "bad syntax in ~s" sexpr)])) - - ;; parse : string -> ALGAE - ;; parses a string containing an ALGAE expression to an ALGAE AST - #;(define: (parse [str : String]) : ALGAE - (parse-sexpr (string->sexpr str))) - - #| Formal specs for `subst': - (`N' is a , `E1', `E2' are s, `x' is some , `y' is a - *different* ) - N[v/x] = N - {+ E ...}[v/x] = {+ E[v/x] ...} - {- E1 E ...}[v/x] = {- E1[v/x] E[v/x] ...} - {* E ...}[v/x] = {* E[v/x] ...} - {/ E1 E ...}[v/x] = {/ E1[v/x] E[v/x] ...} - {= E1 E2}[v/x] = {= E1[v/x] E2[v/x]} - {< E1 E2}[v/x] = {< E1[v/x] E2[v/x]} - {<= E1 E2}[v/x] = {<= E1[v/x] E2[v/x]} - {if E1 E2 E3}[v/x] = {if E1[v/x] E2[v/x] E3[v/x]} - y[v/x] = y - x[v/x] = v - {with {y E1} E2}[v/x] = {with {y E1[v/x]} E2[v/x]} - {with {x E1} E2}[v/x] = {with {x E1[v/x]} E2} -|# - - ;; subst : ALGAE symbol ALGAE -> ALGAE - ;; 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 : ALGAE] [from : Symbol] [to : ALGAE]) : ALGAE - (let ([subst-list (lambda: ([exprs : (Listof ALGAE)]) - (map (lambda: ([x : ALGAE]) (subst x from to)) exprs))]) - (cases expr - [(Num n) expr] - [(Add args) (Add (subst-list args))] - [(Mul args) (Mul (subst-list args))] - [(Sub fst args) (Sub (subst fst from to) (subst-list args))] - [(Div fst args) (Div (subst fst from to) (subst-list args))] - [(Eql l r) (Eql (subst l from to) (subst r from to))] - [(Less l r) (Less (subst l from to) (subst r from to))] - [(LessEql l r) (LessEql (subst l from to) (subst r from to))] - [(If c t e) (If (subst c from to) - (subst t from to) - (subst e from to))] - [(Id id) (if (eq? id from) to expr)] - [(With bound-id named-expr bound-body) - (With bound-id - (subst named-expr from to) - (if (eq? bound-id from) - bound-body - (subst bound-body from to)))]))) - - (define: (subst2 [expr : ALGAE] [from : Symbol] [to : ALGAE]) : ALGAE - (let ([subst-list (lambda: ([exprs : (Listof ALGAE)]) - (map (lambda: ([x : ALGAE]) (subst2 x from to)) exprs))]) - (cond - [(Num? expr) expr] - [(Add? expr) (Add (subst-list (Add-args expr)))] - [(Mul? expr) (Mul (subst-list (Mul-args expr)))] - [(Sub? expr) (Sub (subst2 (Sub-fst expr) from to) (subst-list (Sub-args expr)))] - [(Div? expr) (Div (subst2 (Div-fst expr) from to) (subst-list (Div-args expr)))] - [(Eql? expr) (Eql (subst2 (Eql-lhs expr) from to) (subst2 (Eql-rhs expr) from to))] - [(Less? expr) (Less (subst2 (Less-lhs expr) from to) (subst2 (Less-rhs expr) from to))] - [(LessEql? expr) (LessEql (subst2 (LessEql-lhs expr) from to) (subst2 (LessEql-rhs expr) from to))] - [(If? expr) (If (subst2 (If-cond-expr expr) from to) - (subst2 (If-then-expr expr) from to) - (subst2 (If-else-expr expr) from to))] - [(Id? expr) (if (eq? (Id-name expr) from) to expr)] - [(With? expr) - (With (With-name expr) - (subst2 (With-named expr) from to) - (if (eq? (With-name expr) from) - (With-body expr) - (subst2 (With-body expr) from to)))]))) - - #| Formal specs for `eval': - eval(N) = N - eval({+ E ...}) = eval(E) + ... - eval({- E1}) = -eval(E1) - eval({- E1 E ...}) = eval(E1) - (eval(E) + ...) - eval({* E ...}) = eval(E1) * ... - eval({/ E1}) = 1/eval(E1) - eval({/ E1 E ...}) = eval(E1) / (eval(E) * ...) - eval({= E1 E2}) = 1 if eval(E1)=eval(E2), 0 otherwise - eval({< E1 E2}) = 1 if eval(E1) number - ;; evaluates ALGAE expressions by reducing them to numbers - (define: (-eval [expr : ALGAE]) : Number - (cases expr - [(Num n) n] - [(Add args) (foldl #{+ : (Number Number -> Number)} 0 (map -eval args))] - [(Mul args) (foldl #{* : (Number Number -> Number)} 1 (map -eval args))] - [(Sub fst args) (if (null? args) - (- (-eval fst)) - (- (-eval fst) (foldl #{+ : (Number Number -> Number)} 0 (map -eval args))))] - [(Div fst args) (if (null? args) - (/ (-eval fst)) - (/ (-eval fst) (foldl #{* : (Number Number -> Number)} 1 (map -eval args))))] - [(Eql l r) (if (= (-eval l) (-eval r)) 1 0)] - [(Less l r) (if (< (-eval l) (-eval r)) 1 0)] - [(LessEql l r) (if (<= (-eval l) (-eval r)) 1 0)] - [(If cond then else) (-eval (if (= 0 (-eval cond)) else then))] - [(With bound-id named-expr bound-body) - (-eval (subst bound-body bound-id (Num (-eval named-expr))))] - [(Id id) (error '-eval "free identifier: ~s" id)])) - - ;; run : string -> number - ;; evaluate an ALGAE program contained in a string - #;(define: (run [str : String]) : Number - (-eval (parse str))) - - ;; previous tests - (test 5 <= (run "5")) - (test 10 <= (run "{+ 5 5}")) - (test 20 <= (run "{with {x {+ 5 5}} {+ x x}}")) - (test 10 <= (run "{with {x 5} {+ x x}}")) - (test 14 <= (run "{with {x {+ 5 5}} {with {y {- x 3}} {+ y y}}}")) - (test 4 <= (run "{with {x 5} {with {y {- x 3}} {+ y y}}}")) - (test 15 <= (run "{with {x 5} {+ x {with {x 3} 10}}}")) - (test 8 <= (run "{with {x 5} {+ x {with {x 3} x}}}")) - (test 10 <= (run "{with {x 5} {+ x {with {y 3} x}}}")) - (test 5 <= (run "{with {x 5} {with {y x} y}}")) - (test 5 <= (run "{with {x 5} {with {x x} x}}")) - ;; new tests - (test 0 <= (run "{+}")) - (test 1 <= (run "{*}")) - (test -2 <= (run "{- 2}")) - (test 1/2 <= (run "{/ 2}")) - (test 1/2 <= (run "{/ 1 2}")) - (test 10 <= (run "{+ 1 2 3 4}")) - (test 2 <= (run "{if {< 2 3} 2 3}")) - (test 2 <= (run "{if {<= 3 3} 2 3}")) - (test 3 <= (run "{if {= 2 3} {/ 2 0} 3}")) - (test 1 <= (run "{+ {= 3 3} {< 3 2} {<= 3 2}}")) - (test 1 <= (run "{with {x 2} {= 1/8 {/ {* x 4}}}}")) - (test 1 <= (run "{with {x 2} {if {< 1 2} {<= 1 2} 3}}")) - ;; test errors - (test (run "{-}") =error> "need at least") - (test (run "{/}") =error> "need at least") - (test (run "{= 1 2 3}") =error> "need two args") - (test (run "{< 1}") =error> "need two args") - (test (run "{<=}") =error> "need two args") - (test (run "{with 1}") =error> "bad * syntax") - (test (run "{with {x 1} y}") =error> "free identifier") - (test (run "{if 1}") =error> "need three") - (test (run "{foo 1}") =error> "don't know") - (test (run "{}") =error> "bad syntax in") - - #| Dessert answer: - - Adding `...' (or Kleene star) to our BNF language does not make it - more expressive. An informal proof: say that you have a BNF with - some use of `...' ("?" indicates unknown parts): - - ::= ? | ? ... ? | ? - - we can translate that to a BNF that does not use `...' by inventing a - fresh non-terminal (say that `' is not used elsewhere) and - rewriting the above derivation as follows: - - ::= ? | ? ? | ? - ::= - | <-- an empty derivation - - This can be systematically repeated, and the result will be an - ellipsis-free BNF that is equivalent to the original. - -|# - - #| Bonus answer - - Yes, we could simulate `and' and `or' using arithmetics: - - * use {* x y} instead of {and x y} - - * use {+ {* x x} {* y y}} instead of {or x y} - - ... but that wouldn't be enough to do short circuiting and simulating - Scheme's `and' and `or', because these forms will evaluate *all* of - their subexpressions. To do that properly, we need more than - arithmetics: we need conditionals. For example: - - * use {if x y 0} instead of {and x y} - - * use {if x 1 y} instead of {or x y} - -|# - ) diff --git a/collects/tests/typed-scheme/660-examples/hw04.scm b/collects/tests/typed-scheme/660-examples/hw04.scm deleted file mode 100644 index a9087adf1e..0000000000 --- a/collects/tests/typed-scheme/660-examples/hw04.scm +++ /dev/null @@ -1,349 +0,0 @@ -#reader (planet "typed-reader.ss" ("plt" "typed-scheme.plt")) -(module hw04 "../../typed-scheme.ss" - - (require "support.ss") - -#| This is the updated Algae BNF definition: - ::= { program ... } - ::= { fun { } } - ::= - | { + ... } - | { - ... } - | { * ... } - | { / ... } - | { = } - | { < } - | { <= } - | { if } - | { with { } } - | - | { call } -|# - - -(define-type ALGAE - [Num (n number)] - [Add (args (list-of ALGAE))] - ;; note how Sub & Div match the corresponding BNF derivation - [Sub (fst ALGAE) (args (list-of ALGAE))] - [Mul (args (list-of ALGAE))] - [Div (fst ALGAE) (args (list-of ALGAE))] - [Eql (lhs ALGAE) (rhs ALGAE)] - [Less (lhs ALGAE) (rhs ALGAE)] - [LessEql (lhs ALGAE) (rhs ALGAE)] - [If (cond-expr ALGAE) (then-expr ALGAE) (else-expr ALGAE)] - [Id (name symbol)] - [With (name symbol) (named ALGAE) (body ALGAE)] - [Call (fun symbol) (arg ALGAE)]) - -(define-type FUN - [Fun (name symbol) (arg symbol) (body ALGAE)]) - -(define-type PROGRAM - [Funs (funs (list-of FUN))]) - - -;; parse-program : s-expr -> PROGRAM -;; parses a whole program s-expression into a PROGRAM -#;(define: (parse-program [sexpr : Sexp]) : PROGRAM - (if (and (list? sexpr) - (not (null? sexpr)) - (eq? 'program (first sexpr))) - (Funs (map parse-fun (rest sexpr))) - (error 'parse-program "bad program syntax: ~s" sexpr))) - -;; parse-fun : s-expr -> FUN -;; parses a function s-expression syntax to an instance of FUN -#;(define: (parse-fun [sexpr : Sexp]) : FUN - (if (and ;; check overall structure - (list? sexpr) - (= 4 (length sexpr)) - (eq? 'fun (first sexpr)) - ;; check function name - (symbol? (second sexpr)) - ;; check argument in a sublist - (list? (third sexpr)) - (= 1 (length (third sexpr))) - (symbol? (first (third sexpr)))) - ;; assemble the needed Fun parts - (Fun (second sexpr) - (first (third sexpr)) - (parse-expr (fourth sexpr))) - (error 'parse-program "bad function syntax: ~s" sexpr))) - -;; parse-expr : s-expr -> ALGAE -;; parses an s-expression into an ALGAE abstract syntax tree -#;(define: (parse-expr [sexpr : Sexp]) : ALGAE - (cond - [(number? sexpr) (Num sexpr)] - [(symbol? sexpr) (Id sexpr)] - [(and (list? sexpr) (not (null? sexpr)) - (eq? 'with (first sexpr))) - (if (and (list? (second sexpr)) - (= 2 (length (second sexpr))) - (symbol? (first (second sexpr)))) - (With (first (second sexpr)) - (parse-expr (second (second sexpr))) - (parse-expr (third sexpr))) - (error 'parse-expr "bad `with' syntax"))] - ;; and trick - [(and (list? sexpr) (not (null? sexpr)) - (eq? 'call (first sexpr))) - (if (and (= 3 (length sexpr)) (symbol? (second sexpr))) - (Call (second sexpr) - (parse-expr (third sexpr))) - (error 'parse-expr "bad `call' syntax"))] - ;; and trick - [(and (list? sexpr) (not (null? sexpr))) - (let ([subs (map parse-expr (rest sexpr))]) - (case (first sexpr) - [(+) (Add subs)] - [(-) (if (null? subs) - (error 'parse-expr "need at least one arg for `-'") - (Sub (first subs) (rest subs)))] - [(*) (Mul subs)] - [(/) (if (null? subs) - (error 'parse-expr "need at least one arg for `/'") - (Div (first subs) (rest subs)))] - [(=) (if (= 2 (length subs)) - (Eql (first subs) (second subs)) - (error 'parse-expr "need two args for `='"))] - [(<) (if (= 2 (length subs)) - (Less (first subs) (second subs)) - (error 'parse-expr "need two args for `<'"))] - [(<=) (if (= 2 (length subs)) - (LessEql (first subs) (second subs)) - (error 'parse-expr "need two args for `<='"))] - [(if) (if (= 3 (length subs)) - (If (first subs) (second subs) (third subs)) - (error 'parse-expr "need three exprs for `if'"))] - [else (error 'parse-expr "don't know about ~s" - (first sexpr))]))] - [else (error 'parse-expr "bad syntax in ~s" sexpr)])) - -;; Bonus: -;; verify-functions : PROGRAM -> void -;; this function verifies the list of functions, and doesn't return any -;; useful value. -(define: (verify-functions [prog : PROGRAM]) : Any - ;; this will fail if there is no `main' definition - (lookup-fun 'main prog) - ;; check for repeating names, see helper below - (check-duplicates (map Fun-name (Funs-funs prog)) '()) - ;; finally, scan `Call' syntaxes - (check-calls-list (map Fun-body (Funs-funs prog)) prog)) - -;; check-duplicates : (list-of symbol) (list-of symbol) -> void -;; helper for `verify-functions' -(define: (check-duplicates [symbols : (Listof Symbol)] [seen : (Listof Symbol)]) : Any - ;; `symbols' is what we check, `seen' is names we've already seen - (cond [(null? symbols) 'ok] - [(member (first symbols) seen) - (error 'verify-functions - "duplicate definition: ~s" (first symbols))] - [else (check-duplicates (rest symbols) ;; CHANGE - (cons (first symbols) seen))])) - -;; helper for `verify-functions' -(define: (check-calls-list [funs : (Listof ALGAE)] [prog : PROGRAM]) : Any - (if (null? funs) - 'ok - ;; note that `and' is not really needed below, we just want to use - ;; both expressions so everything is checked. Also in - ;; `check-calls-expr'. - (and (check-calls-expr (first funs) prog) - (check-calls-list (rest funs) prog)))) - -(define: (check-calls-expr [expr : ALGAE] [prog : PROGRAM]) : Any - (cases expr - [(Num n) 'ok] - [(Add args) (check-calls-list args prog)] - [(Mul args) (check-calls-list args prog)] - [(Sub fst args) (check-calls-list (cons fst args) prog)] - [(Div fst args) (check-calls-list (cons fst args) prog)] - [(Eql l r) (and (check-calls-expr l prog) - (check-calls-expr r prog))] - [(Less l r) (and (check-calls-expr l prog) - (check-calls-expr r prog))] - [(LessEql l r) (and (check-calls-expr l prog) - (check-calls-expr r prog))] - [(If c t e) (and (check-calls-expr c prog) - (check-calls-expr t prog) - (check-calls-expr e prog))] - [(Id id) 'ok] - [(With bound-id named-expr bound-body) - (and (check-calls-expr named-expr prog) - (check-calls-expr bound-body prog))] - [(Call fun-name arg) - (and (lookup-fun fun-name prog) - (check-calls-expr arg prog))])) - -;; parse : string -> PROGRAM -;; parses a string containing an ALGAE program to a PROGRAM instance -#;(define (parse str) - (let ([prog (parse-program (string->sexpr str))]) - ;; Bonus answer: the reason we use two expressions is that - ;; `verify-functions' can only signal errors, so it is used only for - ;; its side effect. - (verify-functions prog) - prog)) - -;; subst : ALGAE symbol ALGAE -> ALGAE -;; 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 : ALGAE] [from : symbol] [to : ALGAE]) : ALGAE - (let ([subst-list (lambda: ([exprs : (Listof ALGAE)]) - (map (lambda: ([x : ALGAE]) (subst x from to)) exprs))]) - (cases expr - [(Num n) expr] - [(Add args) (Add (subst-list args))] - [(Mul args) (Mul (subst-list args))] - [(Sub fst args) (Sub (subst fst from to) (subst-list args))] - [(Div fst args) (Div (subst fst from to) (subst-list args))] - [(Eql l r) (Eql (subst l from to) (subst r from to))] - [(Less l r) (Less (subst l from to) (subst r from to))] - [(LessEql l r) (LessEql (subst l from to) (subst r from to))] - [(If c t e) (If (subst c from to) - (subst t from to) - (subst e from to))] - [(Id id) (if (eq? id from) to expr)] - [(With bound-id named-expr bound-body) - (With bound-id - (subst named-expr from to) - (if (eq? bound-id from) - bound-body - (subst bound-body from to)))] - [(Call fun-name arg) (Call fun-name (subst arg from to))]))) - -;; lookup-fun : symbol PROGRAM -> FUN -;; looks up a FUN instance in a PROGRAM given its name -(define: (lookup-fun [name : Symbol] [prog : PROGRAM]) : FUN - (cases prog - [(Funs funs) - (or (ormap (lambda: ([fun : FUN]) - ;; `ormap' will return the first true (= non-#f) - ;; result, so this is both a predicate and returning - ;; the value that is used - (cases fun - [(Fun fname arg expr) (and (eq? fname name) fun)])) - funs) - (error 'lookup-fun - "missing function definition for: ~s" name))])) - -;; eval : ALGAE PROGRAM -> number -;; evaluates ALGAE expressions by reducing them to numbers -;; `prog' is provided for function lookup -(define: (-eval [expr : ALGAE] [prog : PROGRAM]) : Number - ;; note the scoping rules: the following function will call the real - ;; eval, but it expects a single argument, and always uses `prog' - (let ([-eval (lambda: ([expr : ALGAE]) (-eval expr prog))]) - (cases expr - [(Num n) n] - [(Add args) (foldl #{+ :: (Number Number -> Number)} 0 (map -eval args))] - [(Mul args) (foldl #{* :: (Number Number -> Number)} 1 (map -eval args))] - [(Sub fst args) (if (null? args) - (- (-eval fst)) - (- (-eval fst) (foldl #{+ :: (Number Number -> Number)} 0 (map -eval args))))] - [(Div fst args) (if (null? args) - (/ (-eval fst)) - (/ (-eval fst) (foldl #{* :: (Number Number -> Number)} 1 (map -eval args))))] - [(Eql l r) (if (= (-eval l) (-eval r)) 1 0)] - [(Less l r) (if (< (-eval l) (-eval r)) 1 0)] - [(LessEql l r) (if (<= (-eval l) (-eval r)) 1 0)] - [(If cond then else) (-eval (if (= 0 (-eval cond)) else then))] - [(With bound-id named-expr bound-body) - (-eval (subst bound-body bound-id (Num (-eval named-expr))))] - [(Id id) (error '-eval "free identifier: ~s" id)] - [(Call fun-name arg) - (cases (lookup-fun fun-name prog) - [(Fun name bound-id body) - (-eval (subst body bound-id (Num (-eval arg))))])]))) - -;; run : string number -> number -;; evaluate an ALGAE complete program contained in a string using a -;; given value -#;(define: (run [str : String] [arg : Number]) : Number - (let ([prog (parse str)]) - (-eval (Call 'main (Num arg)) prog))) - -;; big test -(test (run "{program - {fun even? {n} - {if {= 0 n} 1 {call odd? {- n 1}}}} - {fun odd? {n} - {if {= 0 n} 0 {call even? {- n 1}}}} - {fun main {n} - {if {= n 1} - 1 - {+ 1 {call main - {if {call even? n} - {/ n 2} - {+ 1 {* n 3}}}}}}}}" - 3) - => 8) -;; test cases for full coverage -(test (run "1" 1) - =error> "bad program syntax") -(test (run "{program 1}" 1) - =error> "bad function syntax") -(test (run "{program {fun main {x} {with {y 1} {+ x y}}}}" 1) - => 2) -(test (run "{program {fun main {x} {with {foo 1} {call foo foo}}} - {fun foo {x} {- x -1}}}" - 1) - => 2) -(test (run "{program {fun main {x} {with y {+ x y}}}}" 1) - =error> "bad `with' syntax") -(test (run "{program {fun main {x} {call 1 2}}}" 1) - =error> "bad `call' syntax") -(test (run "{program {fun main {x} {-}}}" 1) - =error> "need at least one") -(test (run "{program {fun main {x} {/}}}" 1) - =error> "need at least one") -(test (run "{program {fun main {x} {=}}}" 1) - =error> "need two args") -(test (run "{program {fun main {x} {< 1}}}" 1) - =error> "need two args") -(test (run "{program {fun main {x} {<=}}}" 1) - =error> "need two args") -(test (run "{program {fun main {x} {if 1 2 3 4}}}" 1) - =error> "need three exprs") -(test (run "{program {fun main {x} {main 1}}}" 1) - =error> "don't know about") -(test (run "{program {fun main {x} {}}}" 1) - =error> "bad syntax in") -(test (run "{program {fun main {x} x} {fun main {x} x}}" 1) - =error> "duplicate definition") -(test (run "{program {fun main {x} {call foo x}}}" 1) - =error> "missing function definition") -(test (run "{program {fun main {x} y}}" 1) - =error> "free identifier") -(test (run "{program - {fun main {x} - {*{+{*{+{*}{*}}{+{*}{*}{*}{*}}{+{*}{*}{*}{*}}}{*}} - {+{*}{*}{*}{*}{*}} - {+{*}{*}{*}{*}}}}}" 1) - => 660) -(test (run "{program {fun main {x} {+ {< x 3} {<= x 3} {= x 3}}}}" 1) - => 2) -(test (run "{program {fun main {x} {+ {< x 3} {<= x 3} {= x 3}}}}" 3) - => 2) -(test (run "{program {fun main {x} {+ {< x 3} {<= x 3} {= x 3}}}}" 4) - => 0) -(test (run "{program {fun main {x} {* {- x} {/ x}}}}" 2) - => -1) -(test (run "{program {fun main {x} {with {x 2} x}}}" 1) - => 2) -;; can't check `run' since we won't check that the error happend when -;; parsing -(test (parse "{program {fun foo {x} x}}") - =error> "missing function definition for: main") -(test (parse "{program {fun main {x} {call bar x}} {fun foo {x} x}}") - =error> "missing function definition for: bar") -;; test that the language is not higher order -(test 1 <= (run "{program {fun foo {foo} foo} - {fun main {foo} {call foo foo}}}" - 1)) - -) diff --git a/collects/tests/typed-scheme/660-examples/hw05.scm b/collects/tests/typed-scheme/660-examples/hw05.scm deleted file mode 100644 index 4281058dcb..0000000000 --- a/collects/tests/typed-scheme/660-examples/hw05.scm +++ /dev/null @@ -1,222 +0,0 @@ -#reader(planet "typed-reader.ss" ("plt" "typed-scheme.plt")) -(module hw05 "../../typed-scheme.ss" - - (require "support.ss") - - #| -The grammar: - ::= - | { + } - | { - } - | { * } - | { / } - | { with { } } - | - | { fun { } } - | { call } - -Evaluation rules: - eval(N,env) = N - eval({+ E1 E2},env) = eval(E1,env) + eval(E2,env) - eval({- E1 E2},env) = eval(E1,env) - eval(E2,env) - eval({* E1 E2},env) = eval(E1,env) * eval(E2,env) - eval({/ E1 E2},env) = eval(E1,env) / eval(E2,env) - eval(Ref(N),env) = list-ref(env,N) - eval({with {x E1} E2},env) = eval(E2,cons(eval(E1,env),env)) - eval({fun {x} E},env) = <{fun {x} E},env> - eval({call E1 E2},env1) = eval(Ef,cons(eval(E2,env1),env2)) - if eval(E1,env1)=<{fun {x} Ef},env2> - = error! otherwise -|# - - ;; input syntax - (define-type BRANG - [Num (n number)] - [Add (lhs BRANG) (rhs BRANG)] - [Sub (lhs BRANG) (rhs BRANG)] - [Mul (lhs BRANG) (rhs BRANG)] - [Div (lhs BRANG) (rhs BRANG)] - [Id (name symbol)] - [With (name symbol) (named BRANG) (body BRANG)] - [Fun (name symbol) (body BRANG)] - [Call (fun-expr BRANG) (arg-expr BRANG)]) - - ;; preprocessed syntax - (define-type BRANG* - [Num* (n number)] - [Add* (lhs BRANG*) (rhs BRANG*)] - [Sub* (lhs BRANG*) (rhs BRANG*)] - [Mul* (lhs BRANG*) (rhs BRANG*)] - [Div* (lhs BRANG*) (rhs BRANG*)] - [Ref* (idx Number)] - [With* (named BRANG*) (body BRANG*)] - [Fun* (body BRANG*)] - [Call* (fun-expr BRANG*) (arg-expr BRANG*)]) - - ;; parse-sexpr : s-expr -> BRANG - #;(define (parse-sexpr sexpr) - (cond [(number? sexpr) (Num sexpr)] - [(symbol? sexpr) (Id sexpr)] - [(and (list? sexpr) - (not (null? sexpr)) - (eq? 'with (first sexpr))) - (if (and (= 3 (length sexpr)) - (list? (second sexpr)) - (= 2 (length (second sexpr))) - (symbol? (first (second sexpr)))) - (With (first (second sexpr)) - (parse-sexpr (second (second sexpr))) - (parse-sexpr (third sexpr))) - (error 'parse-sexpr "bad `with' syntax"))] - [(and (list? sexpr) - (not (null? sexpr)) - (eq? 'fun (first sexpr))) - (if (and (= 3 (length sexpr)) - (list? (second sexpr)) - (= 1 (length (second sexpr))) - (symbol? (first (second sexpr)))) - (Fun (first (second sexpr)) - (parse-sexpr (third sexpr))) - (error 'parse-sexpr "bad `fun' syntax"))] - [(and (list? sexpr) (= 3 (length sexpr))) - (let ([make-node - (case (first sexpr) - [(+) Add] - [(-) Sub] - [(*) Mul] - [(/) Div] - [(call) Call] - [else (error 'parse-sexpr "don't know about ~s" - (first sexpr))])]) - (make-node (parse-sexpr (second sexpr)) - (parse-sexpr (third sexpr))))] - [else (error 'parse-sexpr "bad syntax in ~s" sexpr)])) - - ;; parse : string -> BRANG - ;; parses a string containing an BRANG expression to a BRANG AST - #;(define (parse str) - (parse-sexpr (string->sexpr str))) - - - ;; These are the values of our language - (define-type VAL - [NumV (n number)] - [FunV (body BRANG*) (env ENV)]) - - ;; NEW - (define-type-alias ENV (Listof VAL)) - - ;; An environment is a simple list of values - ;(define ENV? (list-of VAL?)) - - ;; Syntactic environments for the de-Bruijn preprocessing: - ;; define a type and an empty environment - - ;; this is represented by procedures, but the type should be: - ;; DE-ENV := symbol -> integer - ;; NEW - (define-type-alias DE-ENV (Symbol -> Number)) - - ;; de-empty-env : DE-ENV - ;; the empty syntactic environment, always throws an error - (define: (de-empty-env [id : Symbol]) : Number - (error 'de-env "Free identifier: ~s" id)) - - ;; de-extend : DE-ENV symbol -> DE-ENV - ;; extends a given de-env for a new identifier - (define: (de-extend [env : DE-ENV] [id : Symbol]) : DE-ENV - (lambda: ([name : Symbol]) - (if (eq? id name) - 0 - (+ 1 (env name))))) - ;; test - #;(test (let ([e (de-extend (de-extend de-empty-env 'b) 'a)]) - (map (lambda (id) (e id)) - '(a b))) - => '(0 1)) - - ;; preprocess : BRANG DE-ENV -> BRANG* - ;; replaces identifier expressions into Ref AST values - (define: (preprocess [expr : BRANG] [de-env : DE-ENV]) : BRANG* - (let ([sub (lambda: ([expr : BRANG]) (preprocess expr de-env))]) - (cases expr - [(Num n) (Num* n)] - [(Add l r) (Add* (sub l) (sub r))] - [(Sub l r) (Sub* (sub l) (sub r))] - [(Mul l r) (Mul* (sub l) (sub r))] - [(Div l r) (Div* (sub l) (sub r))] - [(With bound-id named-expr bound-body) - (With* (sub named-expr) - (preprocess bound-body (de-extend de-env bound-id)))] - [(Id id) (Ref* (de-env id))] - [(Fun bound-id bound-body) - (Fun* (preprocess bound-body (de-extend de-env bound-id)))] - [(Call fun-expr arg-expr) - (Call* (sub fun-expr) (sub arg-expr))]))) - - ;; arith-op : (num num -> num) VAL VAL -> VAL - ;; gets a Scheme numeric binary operator, and uses it within a NumV - ;; wrapper - (define: (arith-op [op : (Number Number -> Number)] [val1 : VAL] [val2 : VAL]) : VAL - (define: (NumV->number [v : VAL]) : Number - (cases v - [(NumV n) n] - [else (error 'arith-op "expects a number, got: ~s" v)])) - (NumV (op (NumV->number val1) (NumV->number val2)))) - - ;; eval : BRANG* env -> VAL - ;; evaluates BRANG* expressions by reducing them to values - (define: (-eval [expr : BRANG*] [env : ENV]) : VAL - (cases expr - [(Num* n) (NumV n)] - [(Add* l r) (arith-op + (-eval l env) (-eval r env))] - [(Sub* l r) (arith-op - (-eval l env) (-eval r env))] - [(Mul* l r) (arith-op * (-eval l env) (-eval r env))] - [(Div* l r) (arith-op / (-eval l env) (-eval r env))] - [(With* named-expr bound-body) - (-eval bound-body (cons (-eval named-expr env) env))] - [(Ref* n) (list-ref env n)] - [(Fun* bound-body) (FunV bound-body env)] - [(Call* fun-expr arg-expr) - (let ([fval (-eval fun-expr env)]) - (cases fval - [(FunV bound-body f-env) - (-eval bound-body (cons (-eval arg-expr env) f-env))] - [else (error '-eval "`call' expects a function, got: ~s" - fval)]))])) - #| - ;; run : string -> number - ;; evaluate a BRANG program contained in a string - (define (run str) - (let ([result (-eval (preprocess (parse str) de-empty-env) null)]) - (cases result - [(NumV n) n] - [else (error 'run - "evaluation returned a non-number: ~s" result)]))) - - ;; tests - - (test (run "{call {fun {x} {+ x 1}} 4}") - => 5) - (test (run "{with {add3 {fun {x} {+ x 3}}} - {call add3 1}}") - => 4) - (test (run "{with {add3 {fun {x} {+ x 3}}} - {with {add1 {fun {x} {+ x 1}}} - {with {x 3} - {call add1 {call add3 x}}}}}") - => 7) - (test (run "{with {identity {fun {x} x}} - {with {foo {fun {x} {+ x 1}}} - {call {call identity foo} 123}}}") - => 124) - (test (run "{with {x 3} - {with {f {fun {y} {+ x y}}} - {with {x 5} - {call f 4}}}}") - => 7) - (test (run "{call {call {fun {x} {call x 1}} - {fun {x} {fun {y} {+ x y}}}} - 123}") - => 124) - |#) diff --git a/collects/tests/typed-scheme/660-examples/slow.ss b/collects/tests/typed-scheme/660-examples/slow.ss deleted file mode 100644 index 1e3563db62..0000000000 --- a/collects/tests/typed-scheme/660-examples/slow.ss +++ /dev/null @@ -1,25 +0,0 @@ -(module slow "../../typed-scheme.ss" - (require "../../CSU660/datatype.ss") - -(define-type BINTREE - [Node (l BINTREE) (r BINTREE)] - [Leaf (n number)] - [Q ] - [Q1 ] - [Q2 ] - [Q3 ] - [Q4 ] - [Q5 ] - - ) - -(cases (Leaf 1) - [(Node (Node (Node (Node (Node zz z) x) a) e) b) a] - [(Node a b) a] - [(Q) 1] - [(Q1) 1] - [(Q2) 1] - [(Q3) 1] - [(Q4) 1] - [(Q5) 1] - [(Leaf l) l])) diff --git a/collects/tests/typed-scheme/660-examples/support.ss b/collects/tests/typed-scheme/660-examples/support.ss deleted file mode 100644 index e1af9b4e3d..0000000000 --- a/collects/tests/typed-scheme/660-examples/support.ss +++ /dev/null @@ -1,21 +0,0 @@ -(module support "../../typed-scheme.ss" - (require (for-syntax scheme/base)) - (provide sqr test first second third fourth string->sexpr rest foldl) - - (define: (sqr [a : number]) : number (* a a)) - - (define-type-alias SExp (mu s (Un Number Boolean String Symbol (Listof s)))) - - (define-syntax (test stx) #'#f) - (pdefine: (a) (first [x : (Listof a)]) : a (car x)) - (pdefine: (a) (second [x : (Listof a)]) : a (car (cdr x))) - (pdefine: (a) (third [x : (Listof a)]) : a (car (cdr (cdr x)))) - (pdefine: (a) (fourth [x : (Listof a)]) : a (car (cdr (cdr (cdr x))))) - (pdefine: (a) (rest [x : (Listof a)]) : (Listof a) (cdr x)) - (define: (string->sexpr [s : String]) : Sexp - (read (open-input-string s))) - - #;(define: (list-of [f : (Any -> Any)]) : Any - (lambda: ([l : List]) (andmap f l))) - - )