(* Straightforward implementation of fib has exponential number of * recursive calls. Requires n non-negative. *) let rec fib(n) = if n<2 then 1 else fib(n-1) + fib(n-2) (* However most of these recursive calls share common subproblems - * there are only n distinct subproblems to solve, one for each value * of n. Idea of memoization is to keep track of these results as so * they can be looked up rather than re-computed. *) let fibm(n) = let memo: int option array = Array.create (n+1) None in let rec f_mem(n) = match memo.(n) with Some result -> result (* computed already! *) | None -> let result = if n<2 then 1 else f_mem(n-1) + f_mem(n-2) in memo.(n) <- (Some result); (* record in table *) result in f_mem(n) (* Maximum weight independent set in a tree, office party optimization * problem. *) module Unmemoized = struct type tree = Empty | Node of int * tree * tree (* Returns optimum fun for t. *) let rec party(t) = max (party_in t) (party_out t) (* Returns optimum fun for t assuming the root node of t * is included. *) and party_in(t) = match t with Empty -> 0 | Node(v,left,right) -> v + party_out(left) + party_out(right) (* Returns optimum fun for t assuming the root node of t * is excluded. *) and party_out(t) = match t with Empty -> 0 | Node(v,left,right) -> party(left) + party(right) end module Memoized = struct (* This version memoizes the optimal fun value for each tree node. It also remembers the best invite list. Each tree node has the name of the employee as a string. *) type tree = Empty | Node of int * string * tree * tree * ((int*string list) option) ref let rec party(t): int * string list = match t with Empty -> (0, []) | Node(v,name,left,right,memo) -> (match !memo with Some result -> result | None -> let (infun, innames) = party_in(t) in let (outfun, outnames) = party_out(t) in let result = if infun > outfun then (v + infun, name :: innames) else (outfun, outnames) in (memo := Some result); result) and party_in(t) = match t with Empty -> (0, []) | Node(v,name,l,r,_) -> let (lfun, lnames) = party_out(l) and (rfun, rnames) = party_out(r) in ((v + lfun + rfun), name :: lnames @ rnames) and party_out(t) = match t with Empty -> (0, []) | Node(v,_,l,r,_) -> let (lfun, lnames) = party(l) and (rfun, rnames) = party(r) in ((lfun + rfun), lnames @ rnames) end (* Determine the best way to break a list of words with lengths in the * list "lengths" into a series of lines with maximum length "target". * Different possible ways of doing this are compared based on the sum * of the cubes of the difference between the target width and the actual * width; this has the effect of tending to equalize line lengths. *) let cube(x:int) = x*x*x let big = 10000 (* Result of formatting a string. A result (lst, n) means a string was formatted into the lines in lst, with a total sum-of-cubes cost of n. *) type breakResult = string list * int (* Result: format the words in "words" into a list of lines optimally, * minimizing the sum of the cubes of differences between the line lengths * and "target". * Performance: worst-case time is exponential in the number of words. *) let linebreak1 (words: string list) (target: int): string list = let rec lb(clen: int) (words: string list): breakResult = match words with [] -> ([""], 0) (* no charge for last line *) | word::rest -> (* Try two ways of doing it: (1) insert a linebreak right after * current word, or (2) continue the current line. Pick the * better one. *) let wlen = String.length(word) in let contlen = if clen = 0 then wlen else clen + 1 + wlen in let (l1, c1') = lb 0 rest in let c1 = c1' + cube(target - contlen) in if contlen > target then (word::l1, big) else let (h2::t2, c2) = lb contlen rest in if c1 < c2 then (word::l1, c1) else ((if h2="" then word else word^" "^h2)::t2, c2) in let (result, cost) = lb 0 words in result (* Same spec as linebreak1. Performance: worst-case time is linear in the number of words. *) let linebreak2(words: string list) (target: int): string list = let memo: breakResult option array = Array.create (List.length words+1) None in let rec lb_mem(words: string list): breakResult = let n = List.length words in match Array.get memo n with Some br -> br | None -> let br = lb 0 words in Array.set memo n (Some br); br and lb(clen: int) (words: string list): breakResult = match words with [] -> ([""], 0) (* no charge for last line *) | word::rest -> let wlen = String.length(word) in let contlen = if clen = 0 then wlen else clen + 1 + wlen in let (l1, c1') = lb_mem(rest) in let c1 = c1' + cube(target - contlen) in if contlen > target then (word::l1, big) else let (h2::t2, c2) = lb contlen rest in if c1 < c2 then (word::l1, c1) else ((if h2="" then word else word^" "^h2)::t2, c2) in let (result, cost) = lb 0 words in result let ws = ["The"; "key"; "observation"; "is"; "that"; "in"; "the"; "optimal"; "formatting"; "of"; "a"; "paragraph"; "of"; "text,"; "the"; "formatting"; "of"; "the"; "text"; "past"; "any"; "given"; "point"] let wl = ["The"; "key"; "observation"; "is"; "that"; "in"; "the"; "optimal"; "formatting"; "of"; "a"; "paragraph"; "of"; "text,"; "the"; "formatting"; "of"; "the"; "text"; "past"; "any"; "given"; "point"; "is"; "the"; "optimal"; "formatting"; "of"; "just"; "that"; "text,"; "given"; "that"; "its"; "first"; "character"; "starts"; "at"; "the"; "column"; "position"; "where"; "the"; "prior"; "formatted"; "text"; "ends."; "Thus,"; "the"; "formatting"; "problem"; "has"; "optimal"; "substructure"; "when"; "cast"; "in"; "this"; "way."] (* Using higher-order functions to memoize computations. *) (* General memoization of non-recursive single-argument functions * using a hash table. *) let memo f = let h = Hashtbl.create 11 in fun x -> try Hashtbl.find h x with Not_found -> let y = f x in Hashtbl.add h x y; y (* General memoization of recursive single-argument functions using a * hash table. *) let memo_rec f = let h = Hashtbl.create 11 in let rec g x = try Hashtbl.find h x with Not_found -> let y = f g x in Hashtbl.add h x y; y in g (* Fibonacci using memo_rec *) let fib_memo = let rec fib self = function (n) -> if n<2 then 1 else self(n-1) + self(n-2) in memo_rec fib