funcprog: Finished assignment 11, 12 and 13 of week 5's serie.

funcprog/week5/ass11.ml

+type color = Red | Black;;
+type 'a rbtree = Empty | RBTree of color * 'a rbtree * 'a * 'a rbtree;;
+
+(* Fix the four possible cases that may arise of a red node with a red parent
+ * and black grandparent. *)
+let balance = function
+(* case 1: . *)
+| Black, RBTree(Red, RBTree(Red, a, value, b), y, c), z, d
+(* case 1: The current node N is at the root of the tree. *)
+| Black, RBTree(Red, a, value, RBTree(Red, b , y, c)), z, d
+(* case 1: The current node N is at the root of the tree. *)
+| Black, a, value, RBTree (Red, RBTree (Red, b, y, c), z, d)
+(* case 1: The current node N is at the root of the tree. *)
+| Black, a, value, RBTree (Red, b, y, RBTree (Red, c, z, d))
+    -> RBTree (Red, RBTree (Black, a, value, b), y, RBTree (Black, c, z, d))
+(* case 1: The current node N is at the root of the tree. *)
+| col, a, value, b -> RBTree (col, a, value, b)
+;;
+
+(* 'a rbtree -> 'a -> 'a rbtree *)
+let insert tree value =
+    let rec insert_node = function
+    (* Insertion begins by adding the node and by coloring it red. *)
+    | Empty -> RBTree (Red, Empty, value, Empty)
+    (* Insertion after the first node: *)
+    | RBTree (col, left, y, right) as s ->
+        if value < y then (* Smaller value, thus insert in left tree. *)
+            balance(col, insert_node left, y, right)
+        else if value > y then (* Larger value, thus insert in right tree. *)
+            balance(col, left, y, insert_node right)
+        else (* The node is already inserted. *)
+            s
+    in match insert_node tree with
+    (* Color the root black. *)
+    | RBTree (_, left, y, right) -> RBTree (Black, left, y, right)
+    | Empty -> raise (Failure "Error in insertion")
+;;
+
+(* 'a -> 'a rbtree -> 'a rbtree *)
+let rec lookup value = function
+| Empty -> raise (Failure "Value not found in rbtree.")
+| RBTree(_, left, y, right) as s ->
+    if value = y then
+        s
+    else if value < y then
+        lookup value right
+    else
+        lookup value right
+;;
+
+(* -----------------
+(* remove t x  is a new BST like t but with value x removed, if it
+ * is there. *)
+let rec remove t x = match t with
+| Empty -> Empty (* not found *)
+| RBTree(_, l, x, r) ->
+    (* remove_first n  is (x, n') where x is the lowest value in
+     * n, and n' is n with x removed. Requires: n is not Empty *)
+    let rec remove_first n = match n with
+    | Empty -> raise (Failure "remove_first failed")
+    | RBTree(col, Empty, x, r) -> (x, r)
+    | RBTree(col, l, x, r) ->
+        let (nx, nl) = remove_first l in
+            (nx, RBTree(col, nx, nl, r))
+        in if c > 0 then
+            RBTree(col, l, x, (remove r x))
+        else if c < 0 then
+            RBTree(col, l, x, (remove l x) r)
+        else match l, r with
+        | _, Empty -> l
+        | Empty, _ -> r
+        | _ -> let nx, nr = remove_first r in
+            RBTree(col, nx l nr)
+;;
+*)

funcprog/week5/ass12.ml

+(* vim: set fileencoding=utf-8 : *)
+
+type unary  = Neg | Not
+type binary =   Add | Sub | Mul | Div | Mod    (* arithmetic operators *)
+              | Eq | Ne | Lt | Le | Gt | Ge    (* relational operators *)
+              | And | Or                       (* logic operators *)
+type expr =   Num of int                       (* integer constant *)
+            | Bool of bool                     (* boolean constant *)
+            | Var of string                    (* variable *)
+            | UnaryAp of unary * expr          (* unary operator application *)
+            | BinaryAp of binary * expr * expr (* binary operator application *)
+            | Cond of expr * expr * expr       (* conditional expression *)
+            | Fun of string * expr             (* function abstraction *)
+            | FunAp of expr * expr             (* function application *)
+            | Let of string * expr * expr      (* variable binding *)
+            | LetRec of string * expr * expr   (* recursive variable binding *)
+
+(* Unfortunately, this little gem did not work as expected:
+ *
+ *   let s f l = List.fold_left Printf.sprintf f l
+ *
+ * otherwise, I could eliminate all parentheses after the format string. Since
+ * pattern matching requires an application after "->". *)
+
+(* Convert an expression to a string. *)
+let rec expr2str =
+    (* Translate an unary operator to a string. *)
+    let unary2str = function
+    | Neg -> "-"
+    | Not -> "not "
+    (* Translate a binary operator to a string. *)
+    in let binary2str = function
+    | Add -> "+"
+    | Sub -> "-"
+    | Mul -> "*"
+    | Div -> "/"
+    | Mod -> "mod"
+    | Eq -> "="
+    | Ne -> "!="
+    | Lt -> "<"
+    | Le -> "<="
+    | Gt -> ">"
+    | Ge -> ">="
+    | And -> "&&"
+    | Or -> "||"
+    (* Aliases: *)
+    in let e = expr2str
+    in let s = Printf.sprintf
+    (* Perform the heavy lifting: *)
+    in function
+    | Num i                -> s "%i" i
+    | Bool b               -> s "%b" b
+    | Var v                -> v
+    | UnaryAp(e1, e2)      -> s "%s%s" (unary2str e1) (e e2)
+    | BinaryAp(e1, e2, e3) -> s "%s %s %s" (e e2) (binary2str e1) (e e2)
+    | Cond(e1, e2, e3)     -> s "if %s then %s else %s" (e e1) (e e2) (e e3)
+    | Fun(e1, e2)          -> s "fun %s -> %s" e1 (e e2)
+    | FunAp(e1, e2)        -> (
+        (* Add parentheses for ambiguous cases. *)
+        match e2 with 
+        | BinaryAp(_,_,_)
+        | Cond(_,_,_)
+        | Fun(_, _)
+        | FunAp(_,_)       -> s "%s (%s)" (e e1) (e e2)
+        | _                -> s "%s %s" (e e1) (e e2)
+    )
+    | Let(e1, e2, e3)      -> s "let %s = %s in %s" e1 (e e2) (e e3)
+    | LetRec(e1, e2, e3)   -> s "let rec %s = %s in %s" e1 (e e2) (e e3)
+;;
+
+(* Find all free variables of an expression. *)
+let freevars e =
+    let rec free bound = function
+    | Num _
+    | Bool _ -> []
+    | Var v when List.mem v bound -> []
+    (* Bound: FV(x) = {x}. *)
+    | Var v -> [v]
+    | UnaryAp(_, e) -> free bound e
+    | BinaryAp(_, e1, e2)
+    (* Application: FV((e1 e2)) = FV(e1) U FV(e2). *)
+    | FunAp(e1, e2) -> free bound e1 @ free bound e2
+    | Cond(cond, e1, e2) -> free bound cond @ free bound e1 @ free bound e2
+    (* Abstraction: FV(λ x.e) = FV(e) \ {x}. *)
+    | Fun (arg, e) -> free (arg::bound) e
+    | Let (v, e1, e2) -> free (v::bound) e2 @ free (bound) e1
+    | LetRec (v, e1, e2) -> free (v::bound) e2 @ free (v::bound) e1
+    in free [] e
+;;
+
+(* This function implements substitution, i.e. it yields the expression that
+ * arises from substituting all free occurrences of the variable specified by
+ * the second argument in the expression given as the first argument by the
+ * expression given as third argument. *)
+let rec subs haystack needle replace =
+    (* Alias for normal substitution. *)
+    let s e = subs e needle replace
+    (* Replace x in e with a new variable w, if x will cause a name clash. *)
+    in let unique_var x e =
+        let free_replace = freevars replace in
+        let free_e = freevars e in
+        if List.mem needle free_e && List.mem x free_replace then
+            let all_free_vars = free_replace @ free_e in
+            (* Add primes to the new variable until it is free *)
+            let rec add_prime x =
+                let new_x = x ^ "'" in
+                if List.mem new_x all_free_vars then add_prime x else new_x
+            in
+            let w = add_prime x in
+            Fun(w, s (subs e x (Var w)))
+        else
+            Fun(x, s e)
+    (* Apply substitution rules: *)
+    in match haystack with
+    | Var x when x = needle -> replace
+    (* Substitute operator arguments. *)
+    | UnaryAp(op, e) -> UnaryAp (op, s e)
+    | BinaryAp(op, e1, e2) -> BinaryAp (op, s e1, s e2)
+    (* 1. x = needle: (λ y.e)[a/x] → λ y.e *)
+    | Fun(x, _) as e when x = needle -> e
+    (* 2. x ≠ needle: (λ y.e)[a/x] →
+     *
+     *  if x ∊ FV(e) and y ∊ FV(a):
+     *    create new variable w
+     *    λ w.(e[w/y][a/x])
+     *  else:
+     *    λ y.(e[a/x])
+     *)
+    | Fun(x, e) -> unique_var x e
+    (* Substitute in all sub-expressions. *)
+    | FunAp(e1, e2) -> FunAp(s e1, s e2)
+    | Cond(e1, e2, e3) ->  Cond(s e1, s e2, s e3)
+    (* Only substitue in a 'let' or 'let rec' expression if there is no name
+     * clash with the assigned variable. *)
+    | Let(x, e1, e2) when x != needle -> Let(x, s e1, s e2)
+    | LetRec(x, e1, e2) when x != needle -> LetRec(x, s e1, s e2)
+    (* No substitition rule. *)
+    | _ -> haystack
+;;
+
+(* eval yields the normal form of the given expression using applicative order
+ * reduction (where applicative order reduction yields the normal form). *)
+let rec eval = function
+    (* Unary application. *)
+    | UnaryAp (op, e) -> (
+        match op, eval e with
+        | Neg, Num i -> Num(-i)
+        | Not, Bool b -> Bool(not b)
+        | _ -> raise (Failure "Unknown unary operator")
+    )
+    (* Binary application. *)
+    | BinaryAp (op, e1, e2) -> (
+        match op, e1, e2 with
+        (* An arithmethic or a relational operation is possible on numbers. *)
+        | op, Num a, Num b -> (
+            match op with
+            | Add -> Num(a + b)
+            | Sub -> Num(a - b)
+            | Mul -> Num(a * b)
+            | Div -> Num(a / b)
+            | Mod -> Num(a mod b)
+            | Eq  -> Bool(a = b)
+            | Ne  -> Bool(a != b)
+            | Lt  -> Bool(a < b)
+            | Le  -> Bool(a <= b)
+            | Gt  -> Bool(a > b)
+            | Ge  -> Bool(a >= b)
+            | _   -> raise (Failure "Unknown binary operator")
+        )
+        (* Locical operation is possible on booleans. *)
+        | op, Bool a, Bool b -> (
+            match op with
+            | And -> Bool(a && b)
+            | Or  -> Bool(a || b)
+            | Eq  -> Bool(a = b)
+            | Ne  -> Bool(a != b)
+            | _   -> raise (Failure "Unknown boolean operator")
+        )
+        | op, e1, e2 -> BinaryAp (op, eval e1, eval e2)
+    )
+    | Fun (x, e) -> Fun (x, eval e)
+    (* Function application and expression application. *)
+    | FunAp (Fun (x, Var y), a) when y = x -> eval a
+    | FunAp (Fun (y, e), a)                -> (subs e y a)
+    | FunAp (e1, e2)                       -> FunAp(eval e1, eval e2)
+    (* Condition evaluates to a boolean, else evaluate its arguments. *)
+    | Cond (cond, e1, e2) -> (
+        match eval cond with
+        | Bool b -> if b then eval e1 else eval e2
+        | c      -> Cond(c, eval e1, eval e2)
+    )
+    (* Eval'ing ``let'' and ``let rec'' is basic substitution. *)
+    | Let (x, e1, e2) -> eval (subs e2 x e1)
+    | LetRec (x, e1, e2) -> LetRec(x, eval e1, eval e2)
+    | exp -> exp
+;;

funcprog/week5/ass13.ml

+(* See bottom of ass12.ml for ``eval'' *)