(* -------------------------------------------------- *) (* The now-familiar fold function *) let rec fold (combine: 'a -> 'b -> 'b) (base:'b) (l:'a list) : 'b = begin match l with | [] -> base | h::t -> combine h (fold combine base t) end (* -------------------------------------------------- *) type 'a tree = | Empty | Node of 'a tree * 'a * 'a tree (* Inserts n into the binary search tree t *) let rec insert (n:'a) (t:'a tree) : 'a tree = begin match t with | Empty -> Node(Empty, n, Empty) | Node(lt, x, rt) -> if x = n then t else if n < x then Node (insert n lt, x, rt) else Node(lt, x, insert n rt) end let insert_all (t:'a tree) (l:'a list) : 'a tree = fold insert t l (* Basic implementation of BST removal: *) let rec tree_max (t:'a tree) : 'a = begin match t with | Empty -> failwith "tree_max called on empty tree" | Node(_,x,Empty) -> x | Node(_,_,rt) -> tree_max rt end (* returns a binary search tree that has the same set of nodes as t except with n removed (if it's there) *) let rec delete (n:'a) (t:'a tree) : 'a tree = begin match t with | Empty -> Empty | Node(lt,x,rt) -> if x = n then begin match (lt,rt) with | (Empty, Empty) -> Empty | (Node _, Empty) -> lt | (Empty, Node _) -> rt | _ -> let m = tree_max lt in Node(delete m lt, m, rt) end else if n < x then Node(delete n lt, x, rt) else Node(lt, x, delete n rt) end let delete_all (l: 'a list) (t: 'a tree) : 'a tree = fold delete t l (* A program that's not so nice in a functional style *) (* "Annotated versions" that keep track of how many times tree_max is called: *) (* Basic implementation of BST removal: *) let rec tree_max2 (t:'a tree) : 'a * int = begin match t with | Empty -> failwith "tree_max called on empty tree" | Node(_,x,Empty) -> (x, 1) | Node(_,_,rt) -> let (m, cnt) = tree_max2 rt in (m, cnt+1) end (* returns a binary search tree that has the same set of nodes as t except with n removed (if it's there) *) let rec delete2 (n:'a) (t:'a tree) : 'a tree * int = begin match t with | Empty -> (Empty, 0) | Node(lt,x,rt) -> if x = n then begin match (lt,rt) with | (Empty, Empty) -> (Empty, 0) | (Node _, Empty) -> (lt, 0) | (Empty, Node _) -> (rt, 0) | _ -> let (m, cnt1) = tree_max2 lt in let (lt2, cnt2) = delete2 m lt in (Node(lt2, m, rt), cnt1 + cnt2) end else if n < x then let (lt2, cnt) = delete2 n lt in (Node(lt2, x, rt), cnt) else let (rt2, cnt) = delete2 n rt in (Node(lt, x, rt2), cnt) end let delete_all2 (l: 'a list) (t: 'a tree) : 'a tree * int = let combine (n:'a) (x:'a tree*int) : 'a tree * int = let (delete_all_tl, cnt1) = x in let (ans_t, cnt2) = delete2 n delete_all_tl in (ans_t, cnt1+cnt2) in fold combine (t,0) l (* -------------------------------------------------- *) (* A better way... *) type state = {mutable count : int} let globals : state = {count = 0} let rec tree_max3 (t:'a tree) : 'a = globals.count <- globals.count + 1; (* update the count *) begin match t with | Empty -> failwith "tree_max called on empty tree" | Node(_,x,Empty) -> x | Node(_,_,rt) -> tree_max3 rt end (* returns a binary search tree that has the same set of nodes as t except with n removed (if it's there) *) let rec delete3 (n:'a) (t:'a tree) : 'a tree = begin match t with | Empty -> Empty | Node(lt,x,rt) -> if x = n then begin match (lt,rt) with | (Empty, Empty) -> Empty | (Node _, Empty) -> lt | (Empty, Node _) -> rt | _ -> let m = tree_max3 lt in Node(delete3 m lt, m, rt) end else if n < x then Node(delete3 n lt, x, rt) else Node(lt, x, delete3 n rt) end let delete_all3 (l: 'a list) (t: 'a tree) : 'a tree = fold delete3 t l let t1 = insert_all Empty [1;3;8;2;0;6;7;9;4];; let (t2,cnt) = delete_all2 [2;7;4] t1 let t3 = delete_all3 [2;7;4] t1 (* ------------------------------------------- *) (* Simple examples of using immutable records *) (* a type for representing colors *) type rgb = {r:int; g:int; b:int;} (* some example rgb values *) let red : rgb = {r=255; g=0; b=0;} let blue : rgb = {r=0; g=0; b=255;} let green : rgb = {r=0; g=255; b=0;} let black : rgb = {r=0; g=0; b=0;} let white : rgb = {r=255; g=255; b=255;} (* using 'dot' notation to project out components *) (* calculate the average of two colors *) let average_rgb (c1:rgb) (c2:rgb) : rgb = {r = (c1.r + c2.r) / 2; g = (c1.g + c2.g) / 2; b = (c1.b + c2.b) / 2;} (* using 'with' notation to copy a record but change one (or more) fields *) let cyan = {blue with g=255} let magenta = {red with b=255} let yellow = {green with r=255} (* ----------------------------------------- *) (* Simple examples of using mutable records *) type point = {mutable x:int; mutable y:int} let string_of_point (p:point) : string = "x = " ^ (string_of_int p.x) ^ ", y = " ^ (string_of_int p.y) let p0 = {x=0; y=0;} (* set the x coord of p0 to 17 *) ;; p0.x <- 17 ;; print_endline ("p0 has " ^ (string_of_point p0)) (* a command to shift a point by dx,dy *) let shift (p:point) (dx:int) (dy:int) : unit = p.x <- p.x + dx; p.y <- p.y + dy (* What does this function return? *) let f (p1:point) (p2:point) : int = p1.x <- 17; p2.x <- 42; p1.x (* Consider this call to f *) let ans = f p0 p0 (* Another example of aliasing *) let p1 = {x=1; y=1;} let p2 = p1 ;; shift p2 3 4 ;; print_endline ("p1 has " ^ string_of_point p1) (* Substitution fails: *) let p1 = {x=1; y=1;} let p2 = p1 let ans = p2.x <- 17; p1.x (***********************) (* tree pretty printer *) (***********************) (* NOTE: This portion of the code uses OCaml features that we haven't yet covered in class. We include it here so that you can play around with trees in the top level and print them out in a nice way. The function string_of_tree pretty prints a tree to a string. All of the rest of the functions and datastructures are auxilliary to this main function. Note that string_of_tree assumes that the integers at the nodes of the tree are in the rang [0-9] so that they print as a single character. *) (* a representation of pictures *) type picture = string array (* a picture with some extra information: rootx is the x coordinate (starting from 0) of the root character of this tree *) type tree_block = { width : int; height : int; rootx : int; picture : picture; } let char_of_int (i:int) : char = Char.chr ((Char.code '0') + i) (* creates a new tree block with a root value v rooted at rx *) let new_tb (w:int) (h:int) (rx:int) (v:int) = let pic = Array.init h (fun _ -> String.make w ' ') in let _ = String.set (pic.(0)) rx (char_of_int v) in {width = w; height = h; rootx = rx; picture = pic;} (* inserts newlines into a treeblock to serialize it as a single string *) let string_of_tree_block (b:tree_block) : string = String.concat "\n" (Array.to_list (b.picture)) (* an exception that is raised if there is overlap detected when trying to superimpose two trees *) exception Overlap (* copies one tree_block into another; doesn't check for overlap x = starting x position dy = amount to shift the copied block vertically *) let overwrite (dst:tree_block) (src:tree_block) (x:int) (dy:int) : unit = for i = 0 to src.height - 1 do String.blit (src.picture.(i)) x (dst.picture.(i+dy)) x src.width done (* copies on tree_block into another, checking for collisions (overlap) dx and dy are offsets to shift the source block relative to the target *) let try_to_write (dst:tree_block) (src:tree_block) (dx:int) (dy:int) : unit = for i = 0 to src.height - 1 do for j = 0 to src.width - 1 do let y = i+dy in let x = j+dx in let src_char = String.get (src.picture.(i)) j in if ((String.get (dst.picture.(y)) x) <> ' ') && (src_char <> ' ') then raise Overlap else String.set (dst.picture.(y)) x src_char done done (* draws an left-slanting edge of length el starting at root rx *) let draw_left_edge (dst:tree_block) (el:int) (rx:int) : unit = for i = 1 to el do String.set dst.picture.(i) (rx - i) '/' done (* draws a right-slanting edge of length el starting at root rx *) let draw_right_edge (dst:tree_block) (el:int) (rx:int) : unit = for i = 1 to el do String.set dst.picture.(i) (rx + i) '\\' done (* superimposes two tree_blocks and gives them a new root r. it tries to connect the two trees to the root using an edge of length el. Raises 'Overlap' if there is a collision in this process *) let superimpose (b1:tree_block) (b2:tree_block) (r:int) (el:int) : tree_block = let dx = el * 2 + 2 in let dy = el + 1 in let new_height = dy + (max b1.height b2.height) in let (fixed_block, shifted_block, shift_amt, new_width, new_rootx) = if (b1.rootx + dx) >= b2.rootx then (* b1 is not shifted *) let amt = b1.rootx + dx - b2.rootx in let w = max b1.width (b1.rootx + dx +(b2.width - b2.rootx)) in let rx = b1.rootx + dy in (b1, b2, amt, w, rx) else (* b1 is shifted *) let amt = b2.rootx - (b1.rootx + dx) in let w = max (b1.width + amt) b2.width in let rx = b1.rootx + amt + dy in (b2, b1, amt, w, rx) in let new_block = new_tb new_width new_height new_rootx r in let _ = overwrite new_block fixed_block 0 dy in let _ = try_to_write new_block shifted_block shift_amt dy in let _ = draw_left_edge new_block el new_rootx in let _ = draw_right_edge new_block el new_rootx in new_block (* merges two tree blocks by trying to connect them to a new root. It starts with the smallest possible edge length and increases it until no collision overlaps are detected *) let merge (b1:tree_block) (b2:tree_block) (r:int) : tree_block = let rec loop (el:int) : tree_block = try superimpose b1 b2 r el with | Overlap -> loop (el+1) in loop 1 (* makes a tree_block into the left child of a new root r *) let make_left_child (t:tree_block) (r:int) : tree_block = let new_height = t.height + 2 in let new_width = max (t.width) (t.rootx + 3) in let new_rootx = t.rootx + 2 in let new_block = new_tb new_width new_height new_rootx r in let _ = overwrite new_block t 0 2 in let _ = draw_left_edge new_block 1 new_rootx in new_block (* makes a tree_block into the right child of a new root r *) let make_right_child (t:tree_block) (r:int) : tree_block = let new_height = t.height + 2 in let shift_amt = max 0 (2 - t.rootx) in let new_width = t.width + shift_amt in let new_rootx = max 0 (t.rootx - 2) in let new_block = new_tb new_width new_height new_rootx r in let _ = try_to_write new_block t shift_amt 2 in let _ = draw_right_edge new_block 1 new_rootx in new_block (* creates an empty tree_block *) let empty_block () : tree_block = {height=0; width=0; rootx=0; picture=Array.make 0 ""} (* creates an tree_block with just one node, which is both the root and leaf *) let leaf_block (r:int) : tree_block = {height=1; width=1; rootx=0; picture=Array.make 1 (String.make 1 (char_of_int r));} (* recursively constructs a tree_block from a tree using 'merge' to find an optimal non-overlapping picture for the children *) let rec block_of_tree (t:int tree) : tree_block = begin match t with | Empty -> empty_block () | Node(Empty, r, Empty) -> leaf_block r | Node(Empty, r, rt) -> let rtb = block_of_tree rt in make_right_child rtb r | Node(lt, r, Empty) -> let ltb = block_of_tree lt in make_left_child ltb r | Node(lt, r, rt) -> let ltb = block_of_tree lt in let rtb = block_of_tree rt in merge ltb rtb r end (* The main function: assumes that the nodes are in [0-9] *) let string_of_tree (t:int tree) : string = string_of_tree_block (block_of_tree t)