From: Jim Pryor Date: Fri, 26 Nov 2010 02:57:12 +0000 (-0500) Subject: tweak calc improvements X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=00ea8839bac58c3c1d53460dd34efc4722c8a6f2 tweak calc improvements Signed-off-by: Jim Pryor --- diff --git a/code/calculator/calc1.ml b/code/calculator/calc1.ml index 35b32ffb..554ce7c5 100644 --- a/code/calculator/calc1.ml +++ b/code/calculator/calc1.ml @@ -1,6 +1,6 @@ (* Original calculator from Week7, enhanced with Booleans and Immutable Pairs *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -12,47 +12,47 @@ | First of term ;; - type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value;; - type bound_value = expressed_value;; - type assignment = (char * bound_value) list;; + type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value;; + type bound_value = expressed_value;; + type assignment = (char * bound_value) list;; - let rec eval (t : term) (g : assignment) = match t with - Intconstant x -> Int x - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - (* Multiplication (t1, t2) should evaluate to an Int *) - in Int (i1 * i2) - | Addition (t1, t2) -> - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - in Int (i1 + i2) - | Variable (var) -> - (* we don't handle cases where g doesn't bind var to any value *) - List.assoc var g - | Let (var_to_bind, t2, t3) -> - (* evaluate t3 under a new assignment where var_to_bind has been bound to - the result of evaluating t2 under the current assignment *) - let value2 = eval t2 g - in let g' = (var_to_bind, value2) :: g - in eval t3 g' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let Int i1 = eval t1 g - (* Iszero t1 should evaluate to a Bool *) - in Bool (i1 = 0) - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let Bool b1 = eval t1 g - in if b1 then eval t2 g - else eval t3 g - | Makepair (t1, t2) -> - let value1 = eval t1 g - in let value2 = eval t2 g - in Pair (value1, value2) - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let Pair (value1, value2) = eval t1 g - in value1 + let rec eval (t : term) (g : assignment) = match t with + Intconstant x -> Int x + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + (* Multiplication (t1, t2) should evaluate to an Int *) + in Int (i1 * i2) + | Addition (t1, t2) -> + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + in Int (i1 + i2) + | Variable (var) -> + (* we don't handle cases where g doesn't bind var to any value *) + List.assoc var g + | Let (var_to_bind, t2, t3) -> + (* evaluate t3 under a new assignment where var_to_bind has been bound to + the result of evaluating t2 under the current assignment *) + let value2 = eval t2 g + in let g' = (var_to_bind, value2) :: g + in eval t3 g' + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let Int i1 = eval t1 g + (* Iszero t1 should evaluate to a Bool *) + in Bool (i1 = 0) + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let Bool b1 = eval t1 g + in if b1 then eval t2 g + else eval t3 g + | Makepair (t1, t2) -> + let value1 = eval t1 g + in let value2 = eval t2 g + in Pair (value1, value2) + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let Pair (value1, value2) = eval t1 g + in value1 ;; diff --git a/code/calculator/calc2.ml b/code/calculator/calc2.ml index 57a3342a..ef4a37c6 100644 --- a/code/calculator/calc2.ml +++ b/code/calculator/calc2.ml @@ -1,6 +1,6 @@ (* calc1.ml, enhanced with Function Values *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -15,54 +15,54 @@ ;; type bound_value = expressed_value - and assignment = (char * bound_value) list + and assignment = (char * bound_value) list and expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; - let rec eval (t : term) (g : assignment) = match t with - Intconstant x -> Int x - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - (* Multiplication (t1, t2) should evaluate to an Int *) - in Int (i1 * i2) - | Addition (t1, t2) -> - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - in Int (i1 + i2) - | Variable (var) -> - (* we don't handle cases where g doesn't bind var to any value *) - List.assoc var g - | Let (var_to_bind, t2, t3) -> - (* evaluate t3 under a new assignment where var_to_bind has been bound to - the result of evaluating t1 under the current assignment *) - let value2 = eval t2 g - in let g' = (var_to_bind, value2) :: g - in eval t3 g' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let Int i1 = eval t1 g - (* Iszero t1 should evaluate to a Bool *) - in Bool (i1 = 0) - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let Bool b1 = eval t1 g - in if b1 then eval t2 g - else eval t3 g - | Makepair (t1, t2) -> - let value1 = eval t1 g - in let value2 = eval t2 g - in Pair (value1, value2) - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let Pair (value1, value2) = eval t1 g - in value1 - | Lambda (arg_var, t2) -> Closure (arg_var, t2, g) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let Closure (arg_var, body, savedg) = eval t1 g - in let value2 = eval t2 g - (* evaluate body under savedg, except with arg_var bound to value2 *) - in let savedg' = (arg_var, value2) :: savedg - in eval body savedg' + let rec eval (t : term) (g : assignment) = match t with + Intconstant x -> Int x + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + (* Multiplication (t1, t2) should evaluate to an Int *) + in Int (i1 * i2) + | Addition (t1, t2) -> + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + in Int (i1 + i2) + | Variable (var) -> + (* we don't handle cases where g doesn't bind var to any value *) + List.assoc var g + | Let (var_to_bind, t2, t3) -> + (* evaluate t3 under a new assignment where var_to_bind has been bound to + the result of evaluating t1 under the current assignment *) + let value2 = eval t2 g + in let g' = (var_to_bind, value2) :: g + in eval t3 g' + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let Int i1 = eval t1 g + (* Iszero t1 should evaluate to a Bool *) + in Bool (i1 = 0) + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let Bool b1 = eval t1 g + in if b1 then eval t2 g + else eval t3 g + | Makepair (t1, t2) -> + let value1 = eval t1 g + in let value2 = eval t2 g + in Pair (value1, value2) + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let Pair (value1, value2) = eval t1 g + in value1 + | Lambda (arg_var, t2) -> Closure (arg_var, t2, g) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let Closure (arg_var, body, savedg) = eval t1 g + in let value2 = eval t2 g + (* evaluate body under savedg, except with arg_var bound to value2 *) + in let savedg' = (arg_var, value2) :: savedg + in eval body savedg' ;; diff --git a/code/calculator/calc3.ml b/code/calculator/calc3.ml index 522ca287..65bf7542 100644 --- a/code/calculator/calc3.ml +++ b/code/calculator/calc3.ml @@ -1,6 +1,6 @@ (* calc2.ml, enhanced with Recursive Function Values *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -16,67 +16,67 @@ ;; type bound_value = Nonrecursive of expressed_value | Recursive_Closure of char * char * term * assignment - and assignment = (char * bound_value) list + and assignment = (char * bound_value) list and expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; - let rec eval (t : term) (g : assignment) = match t with - Intconstant x -> Int x - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - (* Multiplication (t1, t2) should evaluate to an Int *) - in Int (i1 * i2) - | Addition (t1, t2) -> - let Int i1 = eval t1 g - in let Int i2 = eval t2 g - in Int (i1 + i2) - | Variable (var) -> ( - (* we don't handle cases where g doesn't bind var to any value *) - match List.assoc var g with + let rec eval (t : term) (g : assignment) = match t with + Intconstant x -> Int x + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + (* Multiplication (t1, t2) should evaluate to an Int *) + in Int (i1 * i2) + | Addition (t1, t2) -> + let Int i1 = eval t1 g + in let Int i2 = eval t2 g + in Int (i1 + i2) + | Variable (var) -> ( + (* we don't handle cases where g doesn't bind var to any value *) + match List.assoc var g with | Nonrecursive value -> value | Recursive_Closure (self_var, arg_var, body, savedg) as rec_closure -> - (* we update savedg to bind self_var to rec_closure here *) + (* we update savedg to bind self_var to rec_closure here *) let savedg' = (self_var, rec_closure) :: savedg in Closure (arg_var, body, savedg') ) - | Let (var_to_bind, t2, t3) -> - (* evaluate t3 under a new assignment where var_to_bind has been bound to + | Let (var_to_bind, t2, t3) -> + (* evaluate t3 under a new assignment where var_to_bind has been bound to the result of evaluating t2 under the current assignment *) - let value2 = eval t2 g - (* we have to wrap value2 in Nonrecursive *) - in let g' = (var_to_bind, Nonrecursive value2) :: g - in eval t3 g' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let Int i1 = eval t1 g - (* Iszero t1 should evaluate to a Bool *) - in Bool (i1 = 0) - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let Bool b1 = eval t1 g - in if b1 then eval t2 g - else eval t3 g - | Makepair (t1, t2) -> - let value1 = eval t1 g - in let value2 = eval t2 g - in Pair (value1, value2) - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let Pair (value1, value2) = eval t1 g - in value1 - | Lambda (arg_var, t2) -> Closure (arg_var, t2, g) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let Closure (arg_var, body, savedg) = eval t1 g - in let value2 = eval t2 g - (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) - in let savedg' = (arg_var, Nonrecursive value2) :: savedg - in eval body savedg' - | Letrec (var_to_bind, t2, t3) -> - (* we don't handle cases where t2 doesn't evaluate to a function value *) - let Closure (arg_var, body, savedg) = eval t2 g + let value2 = eval t2 g + (* we have to wrap value2 in Nonrecursive *) + in let g' = (var_to_bind, Nonrecursive value2) :: g + in eval t3 g' + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let Int i1 = eval t1 g + (* Iszero t1 should evaluate to a Bool *) + in Bool (i1 = 0) + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let Bool b1 = eval t1 g + in if b1 then eval t2 g + else eval t3 g + | Makepair (t1, t2) -> + let value1 = eval t1 g + in let value2 = eval t2 g + in Pair (value1, value2) + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let Pair (value1, value2) = eval t1 g + in value1 + | Lambda (arg_var, t2) -> Closure (arg_var, t2, g) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let Closure (arg_var, body, savedg) = eval t1 g + in let value2 = eval t2 g + (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) + in let savedg' = (arg_var, Nonrecursive value2) :: savedg + in eval body savedg' + | Letrec (var_to_bind, t2, t3) -> + (* we don't handle cases where t2 doesn't evaluate to a function value *) + let Closure (arg_var, body, savedg) = eval t2 g (* evaluate t3 under a new assignment where var_to_bind has been recursively bound to that function value *) - in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g - in eval t3 g' + in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g + in eval t3 g' ;; diff --git a/code/calculator/calc4.ml b/code/calculator/calc4.ml index 571d2776..378e037f 100644 --- a/code/calculator/calc4.ml +++ b/code/calculator/calc4.ml @@ -1,6 +1,6 @@ (* calc3.ml, enhanced with Mutable Cells *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -18,101 +18,101 @@ | Setref of (term * term) ;; - type index = int;; + type index = int;; type bound_value = Nonrecursive of expressed_value | Recursive_Closure of char * char * term * assignment - and assignment = (char * bound_value) list + and assignment = (char * bound_value) list and expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment | Mutcell of index;; - type store = expressed_value list;; + type store = expressed_value list;; - let rec eval (t : term) (g : assignment) (s : store) = match t with - Intconstant x -> (Int x, s) - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - (* Multiplication (t1, t2) should evaluate to an Int *) - in (Int (i1 * i2), s'') - | Addition (t1, t2) -> - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - in (Int (i1 + i2), s'') - | Variable (var) -> ( - (* we don't handle cases where g doesn't bind var to any value *) - match List.assoc var g with + let rec eval (t : term) (g : assignment) (s : store) = match t with + Intconstant x -> (Int x, s) + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + (* Multiplication (t1, t2) should evaluate to an Int *) + in (Int (i1 * i2), s'') + | Addition (t1, t2) -> + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + in (Int (i1 + i2), s'') + | Variable (var) -> ( + (* we don't handle cases where g doesn't bind var to any value *) + match List.assoc var g with | Nonrecursive value -> value | Recursive_Closure (self_var, arg_var, body, savedg) as rec_closure -> - (* we update savedg to bind self_var to rec_closure here *) + (* we update savedg to bind self_var to rec_closure here *) let savedg' = (self_var, rec_closure) :: savedg in Closure (arg_var, body, savedg') ), s - | Let (var_to_bind, t2, t3) -> - (* evaluate t3 under a new assignment where var_to_bind has been bound to + | Let (var_to_bind, t2, t3) -> + (* evaluate t3 under a new assignment where var_to_bind has been bound to the result of evaluating t2 under the current assignment *) - let (value2, s') = eval t2 g s - (* we have to wrap value2 in Nonrecursive *) - in let g' = (var_to_bind, Nonrecursive value2) :: g - in eval t3 g' s' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let (Int i1, s') = eval t1 g s - (* Iszero t1 should evaluate to a Bool *) - in (Bool (i1 = 0), s') - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let (Bool b1, s') = eval t1 g s + let (value2, s') = eval t2 g s + (* we have to wrap value2 in Nonrecursive *) + in let g' = (var_to_bind, Nonrecursive value2) :: g + in eval t3 g' s' + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let (Int i1, s') = eval t1 g s + (* Iszero t1 should evaluate to a Bool *) + in (Bool (i1 = 0), s') + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let (Bool b1, s') = eval t1 g s (* note we thread s' through only one of the then/else clauses *) - in if b1 then eval t2 g s' - else eval t3 g s' - | Makepair (t1, t2) -> - let (value1, s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - in (Pair (value1, value2), s'') - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let (Pair (value1, value2), s') = eval t1 g s - in (value1, s') - | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) - in let savedg' = (arg_var, Nonrecursive value2) :: savedg - in eval body savedg' s'' - | Letrec (var_to_bind, t2, t3) -> - (* we don't handle cases where t2 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t2 g s + in if b1 then eval t2 g s' + else eval t3 g s' + | Makepair (t1, t2) -> + let (value1, s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + in (Pair (value1, value2), s'') + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let (Pair (value1, value2), s') = eval t1 g s + in (value1, s') + | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) + in let savedg' = (arg_var, Nonrecursive value2) :: savedg + in eval body savedg' s'' + | Letrec (var_to_bind, t2, t3) -> + (* we don't handle cases where t2 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t2 g s (* evaluate t3 under a new assignment where var_to_bind has been recursively bound to that function value *) - in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g - in eval t3 g' s' - | Newref (t1) -> - let (starting_val, s') = eval t1 g s - (* note that s' may be different from s, if t1 itself contained any mutation operations *) - (* now we want to retrieve the next free index in s' *) - in let new_index = List.length s' - (* now we want to insert starting_val there; the following is an easy but inefficient way to do it *) - in let s'' = List.append s' [starting_val] - (* now we return a pair of a wrapped new_index, and the new store *) - in (Mutcell new_index, s'') - | Deref (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Mutcell *) - let (Mutcell index1, s') = eval t1 g s - (* note that s' may be different from s, if t1 itself contained any mutation operations *) - in (List.nth s' index1, s') - | Setref (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a Mutcell *) - let (Mutcell index1, s') = eval t1 g s - (* note that s' may be different from s, if t1 itself contained any mutation operations *) - in let (new_value, s'') = eval t2 g s' - (* now we create a list which is just like s'' except it has new_value in index1 *) - in let rec replace_nth lst m = - match lst with - | [] -> failwith "list too short" - | x::xs when m = 0 -> new_value :: xs - | x::xs -> x :: replace_nth xs (m - 1) - in let s''' = replace_nth s'' index1 - (* we'll arbitrarily return Int 42 as the expressed_value of a Setref operation *) - in (Int 42, s''') + in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g + in eval t3 g' s' + | Newref (t1) -> + let (starting_val, s') = eval t1 g s + (* note that s' may be different from s, if t1 itself contained any mutation operations *) + (* now we want to retrieve the next free index in s' *) + in let new_index = List.length s' + (* now we want to insert starting_val there; the following is an easy but inefficient way to do it *) + in let s'' = List.append s' [starting_val] + (* now we return a pair of a wrapped new_index, and the new store *) + in (Mutcell new_index, s'') + | Deref (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Mutcell *) + let (Mutcell index1, s') = eval t1 g s + (* note that s' may be different from s, if t1 itself contained any mutation operations *) + in (List.nth s' index1, s') + | Setref (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a Mutcell *) + let (Mutcell index1, s') = eval t1 g s + (* note that s' may be different from s, if t1 itself contained any mutation operations *) + in let (new_value, s'') = eval t2 g s' + (* now we create a list which is just like s'' except it has new_value in index1 *) + in let rec replace_nth lst m = + match lst with + | [] -> failwith "list too short" + | x::xs when m = 0 -> new_value :: xs + | x::xs -> x :: replace_nth xs (m - 1) + in let s''' = replace_nth s'' index1 + (* we'll arbitrarily return Int 42 as the expressed_value of a Setref operation *) + in (Int 42, s''') ;; diff --git a/code/calculator/calc5.ml b/code/calculator/calc5.ml index bfc91d9f..16e92006 100644 --- a/code/calculator/calc5.ml +++ b/code/calculator/calc5.ml @@ -1,6 +1,6 @@ (* calc3,ml, enhanced with Mutable Pairs *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -16,80 +16,80 @@ | Setfirst of (term * term) ;; - type index = int;; + type index = int;; type bound_value = Nonrecursive of expressed_value | Recursive_Closure of char * char * term * assignment - and assignment = (char * bound_value) list + and assignment = (char * bound_value) list and expressed_value = Int of int | Bool of bool | Pair of index * index | Closure of char * term * assignment;; - type store = expressed_value list;; + type store = expressed_value list;; - let rec eval (t : term) (g : assignment) (s : store) = match t with - Intconstant x -> (Int x, s) - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - (* Multiplication (t1, t2) should evaluate to an Int *) - in (Int (i1 * i2), s'') - | Addition (t1, t2) -> - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - in (Int (i1 + i2), s'') - | Variable (var) -> ( - (* we don't handle cases where g doesn't bind var to any value *) - match List.assoc var g with + let rec eval (t : term) (g : assignment) (s : store) = match t with + Intconstant x -> (Int x, s) + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + (* Multiplication (t1, t2) should evaluate to an Int *) + in (Int (i1 * i2), s'') + | Addition (t1, t2) -> + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + in (Int (i1 + i2), s'') + | Variable (var) -> ( + (* we don't handle cases where g doesn't bind var to any value *) + match List.assoc var g with | Nonrecursive value -> value | Recursive_Closure (self_var, arg_var, body, savedg) as rec_closure -> - (* we update savedg to bind self_var to rec_closure here *) + (* we update savedg to bind self_var to rec_closure here *) let savedg' = (self_var, rec_closure) :: savedg in Closure (arg_var, body, savedg') ), s - | Let (var_to_bind, t2, t3) -> - (* evaluate t3 under a new assignment where var_to_bind has been bound to + | Let (var_to_bind, t2, t3) -> + (* evaluate t3 under a new assignment where var_to_bind has been bound to the result of evaluating t2 under the current assignment *) - let (value2, s') = eval t2 g s - (* we have to wrap value2 in Nonrecursive *) - in let g' = (var_to_bind, Nonrecursive value2) :: g - in eval t3 g' s' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let (Int i1, s') = eval t1 g s - (* Iszero t1 should evaluate to a Bool *) - in (Bool (i1 = 0), s') - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let (Bool b1, s') = eval t1 g s + let (value2, s') = eval t2 g s + (* we have to wrap value2 in Nonrecursive *) + in let g' = (var_to_bind, Nonrecursive value2) :: g + in eval t3 g' s' + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let (Int i1, s') = eval t1 g s + (* Iszero t1 should evaluate to a Bool *) + in (Bool (i1 = 0), s') + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let (Bool b1, s') = eval t1 g s (* note we thread s' through only one of the then/else clauses *) - in if b1 then eval t2 g s' - else eval t3 g s' - | Makepair (t1, t2) -> - let (value1, s') = eval t1 g s - in let (value2, s'') = eval t2 g s' + in if b1 then eval t2 g s' + else eval t3 g s' + | Makepair (t1, t2) -> + let (value1, s') = eval t1 g s + in let (value2, s'') = eval t2 g s' (* now we want to retrieve the next free index in s'' *) in let new_index = List.length s'' (* now we want to insert value1 and value2 there; the following is an easy but inefficient way to do it *) in let s''' = List.append s'' [value1; value2] - in (Pair (new_index, new_index + 1), s''') - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let (Pair (index1, index2), s') = eval t1 g s + in (Pair (new_index, new_index + 1), s''') + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let (Pair (index1, index2), s') = eval t1 g s (* note that s' may be different from s, if t1 itself contained any mutation operations *) in (List.nth s' index1, s') - | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) - in let savedg' = (arg_var, Nonrecursive value2) :: savedg - in eval body savedg' s'' - | Letrec (var_to_bind, t2, t3) -> - (* we don't handle cases where t2 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t2 g s + | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + (* evaluate body under savedg, except with arg_var bound to Nonrecursive value2 *) + in let savedg' = (arg_var, Nonrecursive value2) :: savedg + in eval body savedg' s'' + | Letrec (var_to_bind, t2, t3) -> + (* we don't handle cases where t2 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t2 g s (* evaluate t3 under a new assignment where var_to_bind has been recursively bound to that function value *) - in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g - in eval t3 g' s' + in let g' = (var_to_bind, Recursive_Closure (var_to_bind, arg_var, body, savedg)) :: g + in eval t3 g' s' | Setfirst (t1, t2) -> (* we don't handle cases where t1 doesn't evaluate to a Pair *) let (Pair (index1, index2), s') = eval t1 g s diff --git a/code/calculator/calc6.ml b/code/calculator/calc6.ml index 381e543f..fa3f1832 100644 --- a/code/calculator/calc6.ml +++ b/code/calculator/calc6.ml @@ -1,6 +1,6 @@ (* calc3.ml, enhanced with Mutable Variables *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -16,91 +16,91 @@ | Change of (char * term * term) ;; - type index = int;; + type index = int;; type bound_value = index;; type assignment = (char * bound_value) list;; - type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; + type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; - type store = expressed_value list;; + type store = expressed_value list;; - let rec eval (t : term) (g : assignment) (s : store) = match t with - Intconstant x -> (Int x, s) - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - (* Multiplication (t1, t2) should evaluate to an Int *) - in (Int (i1 * i2), s'') - | Addition (t1, t2) -> - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - in (Int (i1 + i2), s'') - | Variable (var) -> - (* we don't handle cases where g doesn't bind var to any value *) + let rec eval (t : term) (g : assignment) (s : store) = match t with + Intconstant x -> (Int x, s) + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + (* Multiplication (t1, t2) should evaluate to an Int *) + in (Int (i1 * i2), s'') + | Addition (t1, t2) -> + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + in (Int (i1 + i2), s'') + | Variable (var) -> + (* we don't handle cases where g doesn't bind var to any value *) let index = List.assoc var g (* get value stored at location index in s *) in let value = List.nth s index in (value, s) - | Let (var_to_bind, t2, t3) -> - let (value2, s') = eval t2 g s - (* note that s' may be different from s, if t2 itself contained any mutation operations *) + | Let (var_to_bind, t2, t3) -> + let (value2, s') = eval t2 g s + (* note that s' may be different from s, if t2 itself contained any mutation operations *) (* get next free index in s' *) - in let new_index = List.length s' - (* now we want to insert value2 there; the following is an easy but inefficient way to do it *) - in let s'' = List.append s' [value2] + in let new_index = List.length s' + (* now we want to insert value2 there; the following is an easy but inefficient way to do it *) + in let s'' = List.append s' [value2] (* bind var_to_bind to location new_index in the store *) in let g' = ((var_to_bind, new_index) :: g) in eval t3 g' s'' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let (Int i1, s') = eval t1 g s - (* Iszero t1 should evaluate to a Bool *) - in (Bool (i1 = 0), s') - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let (Bool b1, s') = eval t1 g s + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let (Int i1, s') = eval t1 g s + (* Iszero t1 should evaluate to a Bool *) + in (Bool (i1 = 0), s') + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let (Bool b1, s') = eval t1 g s (* note we thread s' through only one of the then/else clauses *) - in if b1 then eval t2 g s' - else eval t3 g s' - | Makepair (t1, t2) -> - let (value1, s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - in (Pair (value1, value2), s'') - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let (Pair (value1, value2), s') = eval t1 g s - in (value1, s') - | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - (* evaluate body under savedg, except with arg_var bound to a new location containing value2 *) + in if b1 then eval t2 g s' + else eval t3 g s' + | Makepair (t1, t2) -> + let (value1, s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + in (Pair (value1, value2), s'') + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let (Pair (value1, value2), s') = eval t1 g s + in (value1, s') + | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + (* evaluate body under savedg, except with arg_var bound to a new location containing value2 *) in let new_index = List.length s'' in let s''' = List.append s'' [value2] - in let savedg' = (arg_var, new_index) :: savedg - in eval body savedg' s''' - | Letrec (var_to_bind, t2, t3) -> - (* we don't handle cases where t2 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t2 g s + in let savedg' = (arg_var, new_index) :: savedg + in eval body savedg' s''' + | Letrec (var_to_bind, t2, t3) -> + (* we don't handle cases where t2 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t2 g s in let new_index = List.length s' in let savedg' = (var_to_bind, new_index) :: savedg in let new_closure = Closure (arg_var, body, savedg') in let s'' = List.append s' [new_closure] in let g' = (var_to_bind, new_index) :: g in eval t3 g' s'' - | Change (var, t2, t3) -> - (* we don't handle cases where g doesn't bind var to any value *) + | Change (var, t2, t3) -> + (* we don't handle cases where g doesn't bind var to any value *) let index = List.assoc var g in let (value2, s') = eval t2 g s - (* note that s' may be different from s, if t2 itself contained any mutation operations *) - (* now we create a list which is just like s' except it has value2 at index *) - in let rec replace_nth lst m = - match lst with - | [] -> failwith "list too short" - | x::xs when m = 0 -> value2 :: xs - | x::xs -> x :: replace_nth xs (m - 1) + (* note that s' may be different from s, if t2 itself contained any mutation operations *) + (* now we create a list which is just like s' except it has value2 at index *) + in let rec replace_nth lst m = + match lst with + | [] -> failwith "list too short" + | x::xs when m = 0 -> value2 :: xs + | x::xs -> x :: replace_nth xs (m - 1) in let s'' = replace_nth s' index (* evaluate t3 using original assignment function and new store *) in eval t3 g s'' diff --git a/code/calculator/calc7.ml b/code/calculator/calc7.ml index 5bfba385..6fc6338d 100644 --- a/code/calculator/calc7.ml +++ b/code/calculator/calc7.ml @@ -1,6 +1,6 @@ (* calc6.ml, enhanced with Aliases and Passing by Reference *) - type term = + type term = Intconstant of int | Multiplication of (term * term) | Addition of (term * term) @@ -18,107 +18,107 @@ | Applyalias of (term * char) ;; - type index = int;; + type index = int;; type bound_value = index;; type assignment = (char * bound_value) list;; - type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; + type expressed_value = Int of int | Bool of bool | Pair of expressed_value * expressed_value | Closure of char * term * assignment;; - type store = expressed_value list;; + type store = expressed_value list;; - let rec eval (t : term) (g : assignment) (s : store) = match t with - Intconstant x -> (Int x, s) - | Multiplication (t1, t2) -> - (* we don't handle cases where the subterms don't evaluate to Ints *) - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - (* Multiplication (t1, t2) should evaluate to an Int *) - in (Int (i1 * i2), s'') - | Addition (t1, t2) -> - let (Int i1, s') = eval t1 g s - in let (Int i2, s'') = eval t2 g s' - in (Int (i1 + i2), s'') - | Variable (var) -> - (* we don't handle cases where g doesn't bind var to any value *) + let rec eval (t : term) (g : assignment) (s : store) = match t with + Intconstant x -> (Int x, s) + | Multiplication (t1, t2) -> + (* we don't handle cases where the subterms don't evaluate to Ints *) + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + (* Multiplication (t1, t2) should evaluate to an Int *) + in (Int (i1 * i2), s'') + | Addition (t1, t2) -> + let (Int i1, s') = eval t1 g s + in let (Int i2, s'') = eval t2 g s' + in (Int (i1 + i2), s'') + | Variable (var) -> + (* we don't handle cases where g doesn't bind var to any value *) let index = List.assoc var g (* get value stored at location index in s *) in let value = List.nth s index in (value, s) - | Let (var_to_bind, t2, t3) -> - let (value2, s') = eval t2 g s - (* note that s' may be different from s, if t2 itself contained any mutation operations *) + | Let (var_to_bind, t2, t3) -> + let (value2, s') = eval t2 g s + (* note that s' may be different from s, if t2 itself contained any mutation operations *) (* get next free index in s' *) - in let new_index = List.length s' - (* now we want to insert value2 there; the following is an easy but inefficient way to do it *) - in let s'' = List.append s' [value2] + in let new_index = List.length s' + (* now we want to insert value2 there; the following is an easy but inefficient way to do it *) + in let s'' = List.append s' [value2] (* bind var_to_bind to location new_index in the store *) in let g' = ((var_to_bind, new_index) :: g) in eval t3 g' s'' - | Iszero (t1) -> - (* we don't handle cases where t1 doesn't evaluate to an Int *) - let (Int i1, s') = eval t1 g s - (* Iszero t1 should evaluate to a Bool *) - in (Bool (i1 = 0), s') - | If (t1, t2, t3) -> - (* we don't handle cases where t1 doesn't evaluate to a boolean *) - let (Bool b1, s') = eval t1 g s + | Iszero (t1) -> + (* we don't handle cases where t1 doesn't evaluate to an Int *) + let (Int i1, s') = eval t1 g s + (* Iszero t1 should evaluate to a Bool *) + in (Bool (i1 = 0), s') + | If (t1, t2, t3) -> + (* we don't handle cases where t1 doesn't evaluate to a boolean *) + let (Bool b1, s') = eval t1 g s (* note we thread s' through only one of the then/else clauses *) - in if b1 then eval t2 g s' - else eval t3 g s' - | Makepair (t1, t2) -> - let (value1, s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - in (Pair (value1, value2), s'') - | First (t1) -> - (* we don't handle cases where t1 doesn't evaluate to a Pair *) - let (Pair (value1, value2), s') = eval t1 g s - in (value1, s') - | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) - | Apply (t1, t2) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t1 g s - in let (value2, s'') = eval t2 g s' - (* evaluate body under savedg, except with arg_var bound to a new location containing value2 *) + in if b1 then eval t2 g s' + else eval t3 g s' + | Makepair (t1, t2) -> + let (value1, s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + in (Pair (value1, value2), s'') + | First (t1) -> + (* we don't handle cases where t1 doesn't evaluate to a Pair *) + let (Pair (value1, value2), s') = eval t1 g s + in (value1, s') + | Lambda (arg_var, t2) -> (Closure (arg_var, t2, g), s) + | Apply (t1, t2) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t1 g s + in let (value2, s'') = eval t2 g s' + (* evaluate body under savedg, except with arg_var bound to a new location containing value2 *) in let new_index = List.length s'' in let s''' = List.append s'' [value2] - in let savedg' = (arg_var, new_index) :: savedg - in eval body savedg' s''' - | Letrec (var_to_bind, t2, t3) -> - (* we don't handle cases where t2 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t2 g s + in let savedg' = (arg_var, new_index) :: savedg + in eval body savedg' s''' + | Letrec (var_to_bind, t2, t3) -> + (* we don't handle cases where t2 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t2 g s in let new_index = List.length s' in let savedg' = (var_to_bind, new_index) :: savedg in let new_closure = Closure (arg_var, body, savedg') in let s'' = List.append s' [new_closure] in let g' = (var_to_bind, new_index) :: g in eval t3 g' s'' - | Change (var, t2, t3) -> - (* we don't handle cases where g doesn't bind var to any value *) + | Change (var, t2, t3) -> + (* we don't handle cases where g doesn't bind var to any value *) let index = List.assoc var g in let (value2, s') = eval t2 g s - (* note that s' may be different from s, if t2 itself contained any mutation operations *) - (* now we create a list which is just like s' except it has value2 at index *) - in let rec replace_nth lst m = - match lst with - | [] -> failwith "list too short" - | x::xs when m = 0 -> value2 :: xs - | x::xs -> x :: replace_nth xs (m - 1) + (* note that s' may be different from s, if t2 itself contained any mutation operations *) + (* now we create a list which is just like s' except it has value2 at index *) + in let rec replace_nth lst m = + match lst with + | [] -> failwith "list too short" + | x::xs when m = 0 -> value2 :: xs + | x::xs -> x :: replace_nth xs (m - 1) in let s'' = replace_nth s' index (* evaluate t3 using original assignment function and new store *) in eval t3 g s'' - | Alias (var_to_bind, orig_var, t3) -> - (* we don't handle cases where g doesn't bind orig_var to any value *) + | Alias (var_to_bind, orig_var, t3) -> + (* we don't handle cases where g doesn't bind orig_var to any value *) let index = List.assoc orig_var g (* bind var_to_bind to the same index in the store *) in let g' = ((var_to_bind, index) :: g) in eval t3 g' s - | Applyalias (t1, var) -> - (* we don't handle cases where t1 doesn't evaluate to a function value *) - let (Closure (arg_var, body, savedg), s') = eval t1 g s - (* we don't handle cases where g doesn't bind var to any value *) + | Applyalias (t1, var) -> + (* we don't handle cases where t1 doesn't evaluate to a function value *) + let (Closure (arg_var, body, savedg), s') = eval t1 g s + (* we don't handle cases where g doesn't bind var to any value *) in let index = List.assoc var g - (* evaluate body under savedg, except with arg_var bound to existing index *) - in let savedg' = (arg_var, index) :: savedg - in eval body savedg' s' + (* evaluate body under savedg, except with arg_var bound to existing index *) + in let savedg' = (arg_var, index) :: savedg + in eval body savedg' s' ;;