About SICP The following O'Caml code is derived from the examples provided in the book:
"Structure and Interpretation of Computer Programs, Second Edition" by Harold Abelson and Gerald Jay Sussman with Julie Sussman.
http://mitpress.mit.edu/sicp/

 ```(* SICP Chapter #03 Examples in O'Caml *) (* Functions defined in previous chapters *) let rec gcd a = function | 0 -> a | b -> gcd b (a mod b) let square_real x = x *. x let average x y = (x +. y) /. 2.0 let rec has_no_divisors n c = c = 1 || (n mod c <> 0 && has_no_divisors n (c-1)) let isPrime n = has_no_divisors n (n-1) let rec enumerate_interval low high = if low > high then [] else low :: enumerate_interval (low+1) high let compose f g x = f(g x) let isOdd n = (n mod 2 = 1) let isEven = compose not isOdd (* 3.1.1 - Assignment and Local State - Local State Variables *) let balance = ref 100 exception InsufficientFunds of int let withdraw amount = if !balance >= amount then begin balance := (!balance - amount); !balance end else raise (InsufficientFunds (!balance)) let _ = withdraw 25 let _ = withdraw 25 let _ = try withdraw 60 with InsufficientFunds b -> b let _ = withdraw 15 let new_withdraw = let balance = ref 100 in fun amount -> if !balance >= amount then begin balance := (!balance - amount); !balance end else raise (InsufficientFunds (!balance)) let make_withdraw balance = let balance = ref balance in fun amount -> if !balance >= amount then begin balance := (!balance - amount); !balance end else raise (InsufficientFunds (!balance)) let w1 = make_withdraw 100 let w2 = make_withdraw 100 let _ = w1 50 let _ = w2 70 let _ = try w2 40 with InsufficientFunds b -> b let _ = w1 40 type ('a, 'b, 'c) account_rec = { withdraw:'a; deposit:'b; balance:'c } (* Record Selector Translation *) let make_account balance = let balance = ref balance in let withdraw amount = if !balance >= amount then begin balance := (!balance - amount); !balance end else raise (InsufficientFunds (!balance)) and deposit amount = balance := (!balance + amount); !balance and getbalance = !balance in { withdraw=withdraw; deposit=deposit; balance=getbalance } let acc = make_account 100 let _ = acc.withdraw 50 let _ = try acc.withdraw 60 with InsufficientFunds b -> b let _ = acc.deposit 40 let _ = acc.withdraw 60 let acc2 = make_account 100 (* end Record Selector Translation *) (* Polymorphic Variants Translation *) type vlist = [`Withdraw | `Deposit] let make_account balance = let balance = ref balance in let withdraw amount = if !balance >= amount then begin balance := (!balance - amount); !balance end else raise (InsufficientFunds (!balance)) and deposit amount = balance := (!balance + amount); !balance in function | (`Withdraw : vlist) -> withdraw | `Deposit -> deposit let acc = make_account 100 let _ = acc `Withdraw 50 let _ = try acc `Withdraw 60 with InsufficientFunds b -> b let _ = acc `Deposit 40 let _ = acc `Withdraw 60 let acc2 = make_account 100 (* end Polymorphic Variants Translation *) (* Exercise 3.1 *) (* exercise left to reader to define appropriate functions let a = make_accumulator 5 let _ = a.f 10 let _ = a.f 10 *) (* Exercise 3.2 *) (* exercise left to reader to define appropriate functions let s = make_monitored sqrt let _ = s.f 100 let _ = s.how_many_calls() *) (* Exercise 3.3 *) (* exercise left to reader to define appropriate functions let acc = make_account 100 "secret-password" let _ = acc.withdraw 40 "secret-password" let _ = acc.withdraw 50 "some-other-password" *) (* 3.1.2 - Assignment and Local State - The Benefits of Introducing Assignment *) let random_init = ref 7 let rand_update x = let a = 27 and b = 26 and m = 127 in (a * x + b) mod m let rand = let x = random_init in fun () -> x := (rand_update !x); !x let cesaro_test () = gcd (rand()) (rand()) = 1 let monte_carlo trials experiment = let rec iter trials_remaining trials_passed = match trials_remaining with | 0 -> float_of_int trials_passed /. float_of_int trials | _ -> if experiment() then iter (trials_remaining - 1) (trials_passed + 1) else iter (trials_remaining - 1) trials_passed in iter trials 0 let estimate_pi trials = sqrt (6. /. (monte_carlo trials cesaro_test)) (* second version (no assignment) *) let random_gcd_test trials initial_x = let rec iter x trials_passed = let x1 = rand_update x in let x2 = rand_update x1 in function | 0 -> (float trials_passed) /. (float trials) | trials_remaining -> iter x2 (if gcd x1 x2 = 1 then (succ trials_passed) else trials_passed) (pred trials_remaining) in iter initial_x 0 trials (* alternate translation *) let random_gcd_test trials initial_x = let rec iter trials_remaining trials_passed x = let x1 = rand_update x in let x2 = rand_update x1 in if trials_remaining = 0 then float_of_int trials_passed /. float_of_int trials else if gcd x1 x2 = 1 then iter (trials_remaining - 1) (trials_passed + 1) x2 else iter (trials_remaining - 1) trials_passed x2 in iter trials 0 initial_x let estimate_pi trials = sqrt (6. /. (random_gcd_test trials !random_init)) (* Exercise 3.6 *) (* exercise left to reader to define appropriate functions fun random_in_range low high = let range = high - low in low + random range end *) (* 3.1.3 - Assignment and Local State - The Cost of Introducing Assignment *) let make_simplified_withdraw balance = let balance = ref balance in fun amount -> balance := !balance - amount; !balance let w = make_simplified_withdraw 25 let _ = w 20 let _ = w 10 let make_decrimenter balance = fun amount -> balance - amount let d = make_decrimenter 25 let _ = d 20 let _ = d 10 let _ = (make_decrimenter 25) 20 let _ = (fun amount -> 25 - amount) 20 let _ = 25 - 20 let _ = (make_simplified_withdraw 25) 20 (* we add an additional step here to handle the introduction of the balance ref *) let _ = (let balance = ref 25 in fun amount -> balance := !balance - amount) 20 let _ = (fun amount -> balance := 25 - amount) 20 let _ = (balance := 25 - 20) (* Sameness and change *) let d2 = make_decrimenter 25 let d2 = make_decrimenter 25 let w1 = make_simplified_withdraw 25 let w2 = make_simplified_withdraw 25 let _ = w1 20 let _ = w1 20 let _ = w2 20 let peter_acc = make_account 100 let paul_acc = make_account 100 let peter_acc = make_account 100 let paul_acc = peter_acc (* Pitfalls of imperative programming *) let factorial n = let rec iter product counter = if counter > n then product else iter (counter * product) (counter + 1) in iter 1 1 let factorial n = let product = ref 1 and counter = ref 1 in let rec iter () = if !counter > n then !product else begin product := !product * !counter; counter := !counter + 1; iter () end in iter () (* Exercise 3.7 *) (* exercise left to reader to define appropriate functions let paul_acc = make_joint peter_acc "open_sesame" "rosebud" *) (* 3.2.1 - The Environment Model of Evaluation - The Rules for Evaluation *) let square x = x * x let square = fun x -> x * x (* 3.2.2 - The Environment Model of Evaluation - Applying Simple Procedures *) let square x = x * x let sum_of_squares x y = square x + square y let f a = sum_of_squares (a + 1) (a * 2) (* exercise 3.9 *) let rec factorial = function | 0 -> 1 | n -> n * factorial (n-1) let rec fact_iter product counter max_count = if counter > max_count then product else fact_iter (counter * product) (counter + 1) max_count let factorial n = fact_iter 1 1 n (* Alternative definition using optional arguments *) let rec fact_iter ?(accu=1) = function | 0 -> accu | n -> fact_iter ~accu:(n*accu) (n-1) let factorial n = fact_iter ~accu:1 n (* 3.2.3 - The Environment Model of Evaluation - Frames as Repository of Local State *) let make_withdraw balance = let balance = ref balance in fun amount -> if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) let w1 = make_withdraw 100 let _ = w1 50 let w2 = make_withdraw 100 (* Exercise 3.10 *) let make_withdraw initial_amount = let balance = ref initial_amount in fun amount -> if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) let w1 = make_withdraw 100 let _ = w1 50 let w2 = make_withdraw 100 (* 3.2.4 - The Environment Model of Evaluation - Internal Definitions *) (* redefine square to work on floats *) let square_real x = x *. x (* same as in section 1.1.8 *) let sqrt' x = let good_enough guess = abs_float(square_real guess -. x) < 0.001 and improve guess = average guess (x /. guess) in let rec sqrt_iter guess = if good_enough guess then guess else sqrt_iter (improve guess) in sqrt_iter 1.0 (* Record Selector Translation *) let make_account balance = let balance = ref balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else failwith "Insufficient funds" and deposit amount = balance := !balance + amount; !balance and getbalance () = !balance in { withdraw=withdraw; deposit=deposit; balance=getbalance } let acc = make_account 50 let _ = acc.deposit 40 let _ = acc.withdraw 60 let acc2 = make_account 100 (* end Record Selector Translation *) (* Polymorphic Variants Translation *) let make_account balance = let balance = ref balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else failwith "Insufficient funds" and deposit amount = balance := !balance + amount; !balance in function | (`Withdraw : vlist) -> withdraw | `Deposit -> deposit let acc = make_account 50 let _ = acc `Deposit 40 let _ = acc `Withdraw 60 let acc2 = make_account 100 (* end Polymorphic Variants Translation *) (* 3.3.1 - Modeling with Mutable Data - Mutable List Structure *) (* Note: ML lists can handle types of 'a ref, but this can't be used to set the tail of the list. To do this trick, we need to define a list that has a ref for the head and tail. Means extra work for ML. A better solution for O'Caml is to use purely functional data structures. *) exception NotFound module type MLIST = sig type 'a mlist = MNil | MCons of 'a ref * 'a mlist ref val cons : 'a -> 'a mlist -> 'a mlist val car : 'a mlist -> 'a val cdr : 'a mlist -> 'a mlist val set_car : 'a mlist -> 'a -> unit val set_cdr : 'a mlist -> 'a mlist -> unit val make_list : 'a list -> 'a mlist val append : 'a mlist -> 'a mlist -> 'a mlist end module MList : MLIST = struct type 'a mlist = MNil | MCons of 'a ref * 'a mlist ref let cons x y = MCons(ref x, ref y) let car = function | MCons(x, xs) -> !x | MNil -> raise NotFound let cdr = function | MCons(x, xs) -> !xs | MNil -> raise NotFound let set_car mlist y = match mlist with | MCons(x, xs) -> (x := y) | MNil -> raise NotFound let set_cdr mlist ys = match mlist with | MCons(x, xs) -> (xs := ys) | MNil -> raise NotFound let make_list xs = List.fold_right (fun v b -> cons v b) xs MNil let rec append mlist ys = match mlist with | MNil -> ys | MCons(x, xs) -> cons (!x) (append (!xs) ys) end (* Sharing and identity *) let x = MList.make_list ["a"; "b"] let z1 = MList.make_list [x; x] let z2 = MList.make_list [MList.make_list ["A"; "B"]; MList.make_list ["A"; "B"]] let set_to_wow x = let _ = MList.set_car (MList.car x) "Wow" in x let _ = z1 let _ = set_to_wow z1 let _ = z2 let _ = set_to_wow z2 (* Mutation as assignment *) module type PAIR' = sig type dispatch = Car | Cdr type ('a,'b) pair' = Left of 'a | Right of 'b val cons : 'a -> 'b -> dispatch -> ('a,'b) pair' val car : (dispatch -> ('a,'b) pair') -> 'a val cdr : (dispatch -> ('a,'b) pair') -> 'b end module Pair' : PAIR' = struct type dispatch = Car | Cdr type ('a,'b) pair' = Left of 'a | Right of 'b let cons x y = let pdispatch = function | Car -> Left x | Cdr -> Right y in pdispatch let car z = match z Car with | Left c -> c | _ -> raise NotFound let cdr z = match z Cdr with | Right c -> c | _ -> raise NotFound end module type MPAIR = sig type dispatch = Car | Cdr | SetCar | SetCdr type ('a,'b) mpair = Left of 'a | Right of 'b | LSet of ('a -> unit) | RSet of ('b -> unit) val cons : 'a -> 'b -> dispatch -> ('a, 'b) mpair val car : (dispatch -> ('a, 'b) mpair) -> 'a val cdr : (dispatch -> ('a, 'b) mpair) -> 'b val set_car : (dispatch -> ('a, 'b) mpair) -> 'a -> unit val set_cdr : (dispatch -> ('a, 'b) mpair) -> 'b -> unit end module MPair : MPAIR = struct type dispatch = Car | Cdr | SetCar | SetCdr type ('a,'b) mpair = Left of 'a | Right of 'b | LSet of ('a -> unit) | RSet of ('b -> unit) let cons x y = let a = ref x and b = ref y in let setx v = (a := v) and sety v = (b := v) in let pdispatch = function | Car -> Left (!a) | Cdr -> Right (!b) | SetCar -> LSet setx | SetCdr -> RSet sety in pdispatch let car z = match z Car with | Left c -> c | _ -> raise NotFound let cdr z = match z Cdr with | Right c -> c | _ -> raise NotFound let set_car z x = match z SetCar with | LSet f -> f x | _ -> raise NotFound let set_cdr z y = match z SetCar with | RSet f -> f y | _ -> raise NotFound end (* This example does not require dynamic dispatch and run-time errors. Indeed, there is nothing dynamic about this example. It was implemented that way in Scheme because this is all that Scheme can do. In OCaml, you can use static checking to eliminate all run-time errors: *) type ('a, 'b) cell = { car: unit -> 'a; cdr: unit -> 'b; set_car: 'a -> unit; set_cdr: 'b -> unit } let cons x y = let x = ref x and y = ref y in { car = (fun () -> !x); cdr = (fun () -> !y); set_car = (fun x' -> x := x'); set_cdr = (fun y' -> y := y') } let x = cons 1 2 let z = cons x x;; (z.cdr()).set_car 17;; x.car();; (* Exercise 3.12 *) let rec last_pair xs = match MList.cdr xs with | MList.MNil -> xs | tail -> last_pair tail let rec mappend xs ys = let _ = MList.set_cdr (last_pair xs) ys in xs let x = MList.make_list ['a'; 'b'] let y = MList.make_list ['c'; 'd'] let z = mappend x y let _ = z let w = mappend x y let _ = w let _ = x (* Exercise 3.13 *) let make_cycle xs = let _ = MList.set_cdr (last_pair xs) xs in xs let z = make_cycle (MList.make_list ['a'; 'b'; 'c']) (* Exercise 3.14 *) let mystery x = let rec loop x y = match x with | MList.MNil -> y | _ -> let temp = MList.cdr x in ( MList.set_cdr x y; loop temp x ) in loop x MList.MNil let v = MList.make_list ['a'; 'b'; 'c'; 'd'] let w = mystery v (* Exercise 3.16 *) (* Write a function to count the number of cons cells in a binary tree. In OCaml, a cons cell is a Node: *) type t = Empty | Node of t * t (* The following incorrect code from the book fails to take cyclic trees into account: *) let rec count = function | Node(a, b) -> 1 + count a + count b | Empty -> 0 (* The following code takes cyclic trees into account: *) let rec count_c ?(nodes=[]) = function | Empty -> 0 | node when List.memq node nodes -> 0 | Node(a, b) as node -> let nodes = node :: nodes in 1 + count_c ~nodes a + count_c ~nodes b (* Here is an example cyclic tree: *) let rec cyclic_tree = Node(cyclic_tree, Empty) (* Exercise 3.20 *) let x = MPair.cons 1 2 let z = MPair.cons x x;; MPair.set_car (MPair.cdr z) 17;; MPair.car x;; (* 3.3.2 - Modeling with Mutable Data - Representing Queues *) (* The book is just trying to implement a mutable queue in Scheme. The following implements a mutable queue in OCaml: *) module Queue(Types : sig type t end) = struct type t = Types.t type cell = { mutable prev: cell option; elt: t; mutable next: cell option } type typ = { mutable front: cell option; mutable rear: cell option} let empty = { front=None; rear=None } let is_empty q = q.front=None let front q = match q.front with | None -> raise Not_found | Some x -> x.elt let insert q x = match q.front with | None -> let cell = Some { prev=None; elt=x; next=None } in q.front <- cell; q.rear <- cell | Some f -> let cell = Some { prev=None; elt=x; next=Some f } in f.prev <- cell; q.front <- cell let delete q = match q.rear with | None -> raise Not_found | Some r -> match r.prev with | None -> let x = r.elt in q.front <- None; q.rear <- None; () | Some r' -> let x = r.elt in r'.next <- None; q.rear <- r.prev; () let to_list q = let rec loop = function | Some c -> c.elt :: loop c.next | None -> [] in loop q.front end (* Exercise 3.21 *) module StringQueue = Queue(struct type t=string end) let q1 = StringQueue.empty;; List.iter (StringQueue.insert q1) ["A"; "B"];; StringQueue.delete q1;; StringQueue.delete q1;; (* 3.3.3 - Modeling with Mutable Data - Representing Tables *) type ('a, 'b) dictionary = Tab of ('a, 'b) dictionary ref | Tree of 'a * 'b * ('a, 'b) dictionary ref | Leaf let rec assoc key record = match record with | Tab xs -> assoc key !xs | Leaf -> Leaf | Tree(k, v, xs) -> if key = k then record else assoc key !xs let lookup key table = let record = assoc key table in match record with | Tree(k, v, _) -> Some (!v) | _ -> None let insert key value table = let record = assoc key table in match record with | Tree(k, v, _) -> (v := value) | _ -> match table with | Tab xs -> (xs := Tree(key, ref value, ref (!xs))) | _ -> raise NotFound let make_table () = Tab(ref Leaf) let d = make_table() let _ = insert "abc" 123 d let x = lookup "abc" d (* two-dimensional *) let lookup2 key1 key2 table = let record = assoc key1 table in match record with | Tree(k1, v, _) -> lookup key2 !v | _ -> None let insert2 key1 key2 value table = let record = assoc key1 table in match record with | Tree(k, v, _) -> insert key2 value !v | _ -> match table with | Tab xs -> let newtab = make_table() in insert key2 value newtab; xs := Tree(key1, ref newtab, ref (!xs)) | _ -> raise NotFound let d = make_table() let _ = insert2 "abc" 123 12.3 d let x = lookup2 "abc" 123 d (* local tables *) module type DICTIONARY2_TYPES = sig type key1type type key2type type valtype end module type DICTIONARY2 = sig include DICTIONARY2_TYPES val get : key1type -> key2type -> valtype option val put : key1type -> key2type -> valtype -> unit end module Dictionary2 (Types : DICTIONARY2_TYPES) = struct type key1type = Types.key1type type key2type = Types.key2type type valtype = Types.valtype type ('a, 'b) dictionary = Tab of ('a, 'b) dictionary ref | Tree of 'a * 'b * ('a, 'b) dictionary ref | Leaf let make_table () = Tab(ref Leaf) let table = make_table() let rec assoc key record = match record with | Tab xs -> assoc key !xs | Leaf -> Leaf | Tree(k, v, xs) -> if key = k then record else assoc key !xs let lookup key table = let record = assoc key table in match record with | Tree(k, v, _) -> Some (!v) | _ -> None let insert key value table = let record = assoc key table in match record with | Tree(k, v, _) -> (v := value) | _ -> match table with | Tab xs -> (xs := Tree(key, ref value, ref (!xs))) | _ -> raise NotFound let get key1 key2 = let record = assoc key1 table in match record with | Tree(k1, v, _) -> lookup key2 !v | _ -> None let put key1 key2 value = let record = assoc key1 table in match record with | Tree(k, v, _) -> insert key2 value !v | _ -> match table with | Tab xs -> let newtab = make_table() in begin insert key2 value newtab; xs := Tree(key1, ref newtab, ref (!xs)) end | _ -> raise NotFound end module D = Dictionary2(struct type key1type=string type key2type=int type valtype=float end) let _ = D.put "abc" 123 12.3 let x = D.get "abc" 123 (* Exercise 3.27 *) let rec fib = function | 0 -> 0 | 1 -> 1 | n -> fib (n-1) + fib (n-2) let memoize f = let table = make_table() in fun x -> let previously_computed_result = lookup x table in match previously_computed_result with | Some item -> item | None -> let result = f x in begin insert x result table; result end let rec memo_fib n = let fib = function | 0 -> 0 | 1 -> 1 | n -> memo_fib(n - 1) + memo_fib(n - 2) in memoize fib n (* Dynamic dispatch is not imposed upon every function in OCaml, you must add it when necessary. To memoize recursive calls inside a function, it is necessary to untie the recursive knot, creating a non-recursive function that accepts the function that it will recurse into as one of its arguments *) let memoize f = let m = Hashtbl.create 1 in let rec f' x = try Hashtbl.find m x with Not_found -> let f_x = f f' x in Hashtbl.add m x f_x; f_x in f' let fib fib = function | 0 -> 0 | 1 -> 1 | n -> fib (n-1) + fib (n-2);; let mem_fib = memoize fib;; (* 3.3.4 - Modeling with Mutable Data - A Simulator for Digital Circuits *) let rec for_each items f = match items with | [] -> () | x::xs -> (f x; for_each xs f) let rec call_each = function | [] -> () | p::ps -> ( p(); call_each ps ) type signal = Hi | Lo type wire = { get_signal_rec : unit -> signal; set_signal_rec : signal -> unit; add_action_rec : (unit->unit)->unit; } let get_signal pwire = pwire.get_signal_rec() let set_signal pwire new_value = pwire.set_signal_rec new_value let add_action pwire action_procedure = pwire.add_action_rec action_procedure let make_wire () = let signal_value = ref Lo and action_procedures = ref [] in let set_my_signal new_value = if !signal_value <> new_value then begin signal_value := new_value; call_each (!action_procedures) end else () and accept_action_procedure proc = action_procedures := proc :: !action_procedures and get_signal () = !signal_value in { get_signal_rec = get_signal; set_signal_rec = set_my_signal; add_action_rec = accept_action_procedure; } let logical_not = function | Lo -> Hi | Hi -> Lo let logical_and s1 s2 = match s1, s2 with | Hi, Hi -> Hi | _ -> Lo let logical_or s1 s2 = match s1, s2 with | Lo, Lo -> Lo | _ -> Hi module ProcQueue = Queue(struct type t=(unit->unit) end) type timesegment = TimeSegment of int ref * ProcQueue.typ let make_time_segment time queue = TimeSegment(ref time, queue) let segment_time (TimeSegment(time, q)) = time let segment_queue (TimeSegment(time, q)) = q (* agenda is a list of time segments *) exception Agenda of string let make_agenda () = MList.cons (make_time_segment 0 ProcQueue.empty) MList.MNil let current_time agenda = !(segment_time(MList.car agenda)) let current_time_ref agenda = segment_time(MList.car agenda) let set_current_time agenda time = (current_time_ref agenda) := time let segments agenda = MList.cdr agenda let set_segments agenda segs = MList.set_cdr agenda segs let first_segment agenda = MList.car(segments agenda) let rest_segments agenda = MList.cdr(segments agenda) let empty_agenda agenda = (segments agenda = MList.MNil) let first_agenda_item agenda = if empty_agenda agenda then raise (Agenda "Agenda is empty -- FIRST-AGENDA-ITEM") else let first_seg = first_segment agenda in begin set_current_time agenda !(segment_time first_seg); ProcQueue.front(segment_queue first_seg) end let remove_first_agenda_item agenda = let q = segment_queue(first_segment agenda) in begin ProcQueue.delete q; if ProcQueue.is_empty q then set_segments agenda (rest_segments agenda) else () end let add_to_agenda time action agenda = let belongs_before = function | MList.MNil -> true | segments -> (time < !(segment_time(MList.car segments))) in let make_new_time_segment time action = let q = ProcQueue.empty in begin ProcQueue.insert q action; make_time_segment time q end in let rec add_to_segments segments = if !(segment_time(MList.car segments)) = time then ProcQueue.insert (segment_queue(MList.car segments)) action else let rest = MList.cdr segments in if belongs_before rest then MList.set_cdr segments (MList.cons (make_new_time_segment time action) (MList.cdr segments)) else add_to_segments rest and segs = segments agenda in if belongs_before segs then set_segments agenda (MList.cons (make_new_time_segment time action) segs) else add_to_segments segs let the_agenda = make_agenda() let after_delay delay action = add_to_agenda (delay + (current_time the_agenda)) action the_agenda let inverter_delay = 2 let and_gate_delay = 3 let or_gate_delay = 5 let inverter input output = let new_value = logical_not(get_signal input) in let invert_input () = after_delay inverter_delay (fun () -> set_signal output new_value) in add_action input invert_input let and_gate a1 a2 output = let new_value = logical_and (get_signal a1) (get_signal a2) in let and_action_procedure () = after_delay and_gate_delay (fun () -> set_signal output new_value) in begin add_action a1 and_action_procedure; add_action a2 and_action_procedure end let or_gate a1 a2 output = let new_value = logical_or (get_signal a1) (get_signal a2) in let or_action_procedure () = after_delay or_gate_delay (fun () -> set_signal output new_value) in begin add_action a1 or_action_procedure; add_action a2 or_action_procedure end let half_adder a b s c = let d = make_wire() and e = make_wire() in begin or_gate a b d; and_gate a b c; inverter c e; and_gate d e s end let or_gate a1 a2 output = let b = make_wire() and c = make_wire() and d = make_wire() in begin inverter a1 b; inverter a2 c; and_gate b c d; inverter d output end let a = make_wire() let b = make_wire() let c = make_wire() let d = make_wire() let e = make_wire() let s = make_wire();; or_gate a b d;; and_gate a b c;; inverter c e;; and_gate d e s;; let full_adder a b c_in sum c_out = let s = make_wire() and c1 = make_wire() and c2 = make_wire() in begin half_adder b c_in s c1; half_adder a s sum c2; or_gate c1 c2 c_out end let rec propagate () = if empty_agenda the_agenda then () else let first_item = first_agenda_item the_agenda in begin first_item(); remove_first_agenda_item the_agenda; propagate() end let signal_to_string = function | Hi -> "Hi" | Lo -> "Lo" let probe name pwire = add_action pwire (fun () -> begin print_string name; print_string " "; print_string (string_of_int (current_time the_agenda)); print_string " New-value = "; print_string (signal_to_string(get_signal pwire)); print_string "\n" end) (* Sample simulation *) let input_1 = make_wire() let input_2 = make_wire() let sum = make_wire() let carry = make_wire();; probe "sum" sum;; probe "carry" carry;; half_adder input_1 input_2 sum, carry;; set_signal input_1 Hi;; propagate();; set_signal input_2 Hi;; propagate();; (* Exercise 3.31 *) (* let accept_action_procedure proc = action_procedures := proc::action_procedures *) (* 3.3.5 - Modeling with Mutable Data - Propagation of Constraints *) exception Constraint of string type propagator = { process_new_value : unit -> unit; process_forget_value : unit -> unit } let inform_about_value prop = prop.process_new_value() let inform_about_no_value prop = prop.process_forget_value() type 'a connector = { has_value : unit -> bool; get_value : unit -> 'a; set_value : 'a -> propagator -> unit; forget_value : propagator -> unit; connect : propagator -> unit; } let has_value conn = conn.has_value() let get_value conn = conn.get_value() let set_value conn new_value informant = conn.set_value new_value informant let forget_value conn retractor = conn.forget_value retractor let connect conn new_constraint = conn.connect new_constraint let for_each_except except procedure listx = let rec loop = function | [] -> () | x::xs -> if x == except then loop xs else begin procedure x; loop xs end in loop listx let rec propagator_list_contains items v = match items with | x::xs -> x == v || propagator_list_contains xs v | [] -> false let is_null = function | [] -> true | x::xs -> false let make_connector () = let value_list = ref [] and informant_list = ref [] and constraints = ref [] in let has_value () = (!value_list <> []) and get_value () = List.hd (!value_list) and informant () = List.hd (!informant_list) in let set_value newval setter = if not(has_value()) then begin value_list := [newval]; informant_list := [setter]; for_each_except setter inform_about_value !constraints end else if get_value() <> newval then raise (Constraint "Contradiction") else () and forget_value retractor = if not(is_null !informant_list) && retractor == informant() then begin informant_list := []; value_list := []; for_each_except retractor inform_about_no_value !constraints end else () and connect new_constraint = begin if not(propagator_list_contains (!constraints) new_constraint) then constraints := new_constraint :: !constraints else (); if has_value() then inform_about_value new_constraint else () end in { has_value=has_value; get_value=get_value; set_value=set_value; forget_value=forget_value; connect=connect } let adder a1 a2 sum = let rec this = { process_new_value=process_new_value; process_forget_value=process_forget_value } and process_new_value () = if has_value a1 && has_value a2 then set_value sum (get_value a1 +. get_value a2) this else if has_value a1 && has_value sum then set_value a2 (get_value sum -. get_value a1) this else if has_value a2 && has_value sum then set_value a1 (get_value sum -. get_value a2) this else () and process_forget_value () = begin forget_value sum this; forget_value a1 this; forget_value a2 this; process_new_value() end in connect a1 this; connect a2 this; connect sum this; this let multiplier m1 m2 product = let rec this = { process_new_value=process_new_value; process_forget_value=process_forget_value } and process_new_value () = if (has_value m1 && get_value m1 = 0.0) || (has_value m2 && get_value m2 = 0.0) then set_value product 0.0 this else if has_value m1 && has_value m2 then set_value product (get_value m1 *. get_value m2) this else if has_value product && has_value m1 then set_value m2 (get_value product /. get_value m1) this else if has_value product && has_value m2 then set_value m1 (get_value product /. get_value m2) this else () and process_forget_value () = begin forget_value product this; forget_value m1 this; forget_value m2 this; process_new_value() end in connect m1 this; connect m2 this; connect product this; this let constant (value : float) (connector : float connector) = let rec this = { process_new_value=process_new_value; process_forget_value=process_forget_value } and process_new_value () = raise (Constraint "Unknown request -- CONSTANT -- process_new_value") and process_forget_value () = raise (Constraint "Unknown request -- CONSTANT -- process_forget_value") in connect connector this; set_value connector value this; this let probe name connector = let rec this = { process_new_value=process_new_value; process_forget_value=process_forget_value } and print_probe value = begin print_string "Probe: "; print_string name; print_string " = "; print_string (string_of_float value); print_string "\n" end and process_new_value () = print_probe(get_value(connector)) and process_forget_value () = begin print_string "Probe: "; print_string name; print_string " = "; print_string "?"; print_string "\n" end in connect connector this; this let user = { process_new_value = (fun ()->()); process_forget_value = (fun ()->()) } let celsius_fahrenheit_converter c f = let u = make_connector() and v = make_connector() and w = make_connector() and x = make_connector() and y = make_connector() in begin multiplier c w u; multiplier v x u; adder v y f; constant 9.0 w; constant 5.0 x; constant 32.0 y; () end let (c : float connector) = make_connector() let (f : float connector) = make_connector() let _ = celsius_fahrenheit_converter c f let _ = probe "Celsius temp" c let _ = probe "Fahrenheit temp" f let _ = set_value c 100.0 user let _ = forget_value c user let _ = set_value f 32.0 user (* Exercise 3.34 *) let squarer a b = multiplier a a b (* Exercise 3.36 *) let (a : float connector) = make_connector() let (b : float connector) = make_connector() let _ = set_value a 10. user (* Exercise 3.37 *) (* exercise left to reader to define appropriate functions let celsius_fahrenheit_converter x = c_plus (c_times (c_divide (cv 9) (cv 5)) x) (cv 32) let c = make_connector() let f = celsius_fahrenheit_converter(c) let c_plus x y = let z = make_connector() in begin adder x y z; z end *) (* 3.4.1 - Concurrency: Time Is of the Essence - The Nature of Time in Concurrent Systems *) let balance = ref 100 exception InsufficientFunds of int let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) (* Exercise 3.38 *) let _ = balance := !balance + 10 let _ = balance := !balance - 20 let _ = balance := !balance - (!balance / 2) (* 3.4.2 - Concurrency: Time Is of the Essence - Mechanisms for Controlling Concurrency *) (* CMR: -thread -custom threads.cma \$File -cclib -lthreads *) module Thread = struct let create m = m end module Mutex = struct type ('a, 'b) t = ('a -> 'b) -> 'a -> 'b let create () = () let lock m = () let unlock m = () end let parallel_execute f1 f2 = ( Thread.create f1(); Thread.create f2() ) let x = ref 10;; parallel_execute (fun () -> x := !x * !x) (fun () -> x := !x + 1);; (* Implementing serializers *) let make_mutex () = Mutex.create() let make_serializer () = let mutex = make_mutex() in fun p x -> begin Mutex.lock mutex; let v = p x in begin Mutex.unlock mutex; v end end let x = ref 10 let s = make_serializer();; parallel_execute (s (fun () -> x := !x * !x)) (s (fun () -> x := !x + 1));; let make_account init_balance = let balance = ref init_balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) and deposit amount = (balance := !balance + amount; !balance) and getbalance () = !balance in { withdraw=make_serializer() withdraw; deposit=make_serializer() deposit; balance=getbalance } (* Exercise 3.39 *) let x = ref 10 let s = make_serializer();; parallel_execute (fun () -> x := (s (fun () -> !x * !x))()) (s (fun () -> (x := !x + 1; !x)));; (* Exercise 3.40 *) let x = ref 10;; parallel_execute (fun () -> x := !x * !x) (fun () -> x := !x * !x * !x);; let x = ref 10 let s = make_serializer();; parallel_execute (s (fun () -> x := !x * !x)) (s (fun () -> x := !x * !x * !x));; (* Exercise 3.41 *) let make_account init_balance = let balance = ref init_balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) and deposit amount = (balance := !balance + amount; !balance) in { withdraw=make_serializer() withdraw; deposit=make_serializer() deposit; balance=make_serializer() (fun () -> !balance) } (* Exercise 3.42 *) let make_account init_balance = let balance = ref init_balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) and deposit amount = (balance := !balance + amount; !balance) and getbalance () = !balance in let protected_withdraw = make_serializer() withdraw and protected_deposit = make_serializer() deposit in { withdraw=protected_withdraw; deposit=protected_deposit; balance=getbalance } (* Multiple shared resources *) type ('a, 'b) acct = { withdraw:int->int; deposit:int->int; balance:unit->int; serializer:('a, 'b) Mutex.t } let make_account init_balance = let balance = ref init_balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) and deposit amount = (balance := !balance + amount; !balance) and getbalance () = !balance in { withdraw=withdraw; deposit=deposit; balance=getbalance; serializer=make_serializer () } let exchange account1 account2 = let difference = account1.balance() - account2.balance() in account1.withdraw difference; account2.deposit difference; difference let deposit account amount = let s = account.serializer and d = account.deposit in s d amount (* CMR Error: not sure how to get types correct for this example let serialized_exchange account1 account2 = let serializer1 = account1.serializer and serializer2 = account2.serializer in serializer1 serializer2 exchange account1 account2 *) (* Exercise 3.44 *) let transfer from_account to_account amount = begin from_account.withdraw amount; to_account.deposit amount end (* Exercise 3.45 *) let make_account init_balance = let balance = ref init_balance in let withdraw amount = if !balance >= amount then (balance := !balance - amount; !balance) else raise (InsufficientFunds (!balance)) and deposit amount = (balance := !balance + amount; !balance) and getbalance () = !balance and serializer = make_serializer() in { withdraw=serializer withdraw; deposit=serializer deposit; balance=getbalance; serializer=serializer } let deposit account amount = account.deposit amount (* 3.5.1 - Streams - Streams Are Delayed Lists *) let sum_primes a b = let rec iter count accum = if count > b then accum else if isPrime count then iter (count + 1) (count + accum) else iter (count + 1) accum in iter a 0 let sum_primes a b = List.fold_right ( + ) (List.filter isPrime (enumerate_interval a b)) 0;; (* List.hd (List.tl (List.filter isPrime (enumerate_interval 10000 1000000)));; *) type 'a node_t = | Empty | Node of 'a * 'a node_t lazy_t let force a = Lazy.force a let the_empty_stream = lazy Empty let stream_null stream = match Lazy.force stream with | Empty -> true | _ -> false let cons_stream x xs = lazy (Node(x, xs)) let stream_car stream = match Lazy.force stream with | Node(x, xs) -> x | Empty -> raise Not_found let stream_cdr stream = match Lazy.force stream with | Node(x, xs) -> xs | Empty -> raise Not_found let rec take stream n = if n == 0 then [] else match Lazy.force stream with | Node(x, xs) -> x :: take xs (n-1) | Empty -> raise Not_found let stream_ref = take let rec stream_map proc stream = lazy begin match Lazy.force stream with | Empty -> Empty | Node(x, xs) -> Node(proc x, stream_map proc xs) end let rec stream_for_each proc stream = match Lazy.force stream with | Empty -> () | Node(x, xs) -> begin proc x; stream_for_each proc xs end let display_line x = begin print_string (string_of_int x); print_string "\n" end let display_stream stream = stream_for_each display_line stream let rec stream_enumerate_interval low high = lazy begin if low > high then Empty else Node(low, stream_enumerate_interval (low + 1) high) end let rec stream_filter pred stream = lazy begin match Lazy.force stream with | Empty -> Empty | Node(x, xs) -> if (pred x) then Node(x, stream_filter pred xs) else Lazy.force (stream_filter pred xs) end let s0 = cons_stream 1 (cons_stream 2 (cons_stream 3 (lazy Empty))) let s1 = stream_enumerate_interval 2 100 let s2 = stream_map isPrime s1 let s3 = stream_filter isPrime s1 let s4 = stream_car(stream_cdr(stream_filter isPrime (stream_enumerate_interval 10000 1000000))) (* CMR: Still need to convert this one let memo_proc proc = let already_run = ref false and result = Promise.promise() in fn () => if not (!already_run) then let in already_run := true; Promise.fulfill(result, proc()); Promise.future result end else Promise.future result end *) (* Exercise 3.51 *) let show x = begin print_string (string_of_int x); print_string "\n" end let x = stream_map show (stream_enumerate_interval 0 10) let _ = take x 5 let _ = take x 7 (* Exercise 3.52 *) let sum = ref 0 let accum x = begin sum := !sum + x; !sum end let seq = stream_map accum (stream_enumerate_interval 1 20) let y = stream_filter isEven seq let z = stream_filter (fun x -> (x mod 5) = 0) seq let _ = take y 7 let _ = display_stream z (* 3.5.2 - Streams - Infinite Streams *) let rec integers_starting_from n = lazy begin Node(n, integers_starting_from (n + 1)) end let integers = integers_starting_from 1 let isDivisible x y = ((x mod y) = 0) let no_sevens = stream_filter (fun x -> not(isDivisible x 7)) integers let _ = take no_sevens 100 let rec fibgen a b = lazy (Node(a, fibgen b (a + b))) let fibs = fibgen 0 1 let rec sieve stream = lazy begin match Lazy.force stream with | Node(x, xs) -> Node(x, sieve (stream_filter (fun y -> not(isDivisible y x)) xs)) | Empty -> raise Not_found end let primes = sieve (integers_starting_from 2) let _ = take primes 50 (* Defining streams implicitly *) let rec ones_gen () = lazy (Node(1, ones_gen())) let ones = ones_gen() let rec add_streams s1 s2 = lazy begin match Lazy.force s1, Lazy.force s2 with | Node(x, xs), Node(y, ys) -> Node(x + y, add_streams xs ys) | _, _ -> raise Not_found end let rec integers_gen () = lazy begin Node(1, add_streams ones (integers_gen())) end let integers = integers_gen() let rec fibs_gen () = lazy begin Node(0, lazy ( Node(1, add_streams (stream_cdr (fibs_gen())) (fibs_gen())))) end let fibs = fibs_gen() let scale_stream stream factor = stream_map (fun x -> x * factor) stream let rec double_gen () = lazy (Node(1, scale_stream (double_gen()) 2)) let double = double_gen() let primes_gen () = lazy (Node(2, stream_filter isPrime (integers_starting_from 3))) let primes = primes_gen() let isPrime n = let rec iter ps = let x = stream_car ps in if square x > n then true else if isDivisible n x then false else iter(stream_cdr ps) in iter primes (* Exercise 3.53 *) let rec s_gen () = lazy (Node(1, add_streams (s_gen()) (s_gen()))) let s = s_gen() (* Exercise 3.56 *) let rec merge s1 s2 = match Lazy.force s1, Lazy.force s2 with | Empty, _ -> s2 | _, Empty -> s1 | Node(x, xs), Node(y, ys) -> if x < y then lazy (Node(x, merge xs s2)) else if x > y then lazy (Node(y, merge s1 ys)) else lazy (Node(x, merge xs ys)) (* Exercise 3.58 *) let rec expand num den radix = lazy begin Node((num * radix) / den, expand ((num * radix) mod den) den radix) end (* Exercise 3.59 *) (* exercise left to reader to define appropriate functions let exp_series_gen () = lazy (Node(1, integrate_series (exp_series_gen()))) let gen = exp_series_gen() *) (* 3.5.3 - Streams - Exploiting the Stream Paradigm *) let sqrt_improve guess x = average guess (x /. guess) let sqrt_stream x = let rec guesses_gen () = lazy (Node(1.0, stream_map (fun guess -> sqrt_improve guess x) (guesses_gen()))) in guesses_gen() let _ = take (sqrt_stream 2.0) 5 let rec add_streams_real s1 s2 = lazy begin match Lazy.force s1, Lazy.force s2 with | Node(x, xs), Node(y, ys) -> Node(x +. y, add_streams_real xs ys) | _, _ -> raise Not_found end let rec partial_sums stream = lazy begin Node(stream_car stream, add_streams_real (partial_sums stream) (stream_cdr stream)) end let scale_stream_real stream factor = stream_map (fun x -> x *. factor) stream let rec pi_summands n = lazy begin Node(1.0 /. float_of_int n, stream_map (fun x -> 0.0 -. x) (pi_summands (n + 2))) end let pi_stream_gen () = scale_stream_real (partial_sums (pi_summands 1)) 4.0 let pi_stream = pi_stream_gen() let _ = take pi_stream 8 let rec stream_nth stream n = match Lazy.force stream with | Node(x, xs) -> if n = 0 then x else stream_nth xs (n-1) | _ -> raise Not_found let rec euler_transform stream = lazy begin let s0 = stream_nth stream 0 and s1 = stream_nth stream 1 and s2 = stream_nth stream 2 in Node(s2 -. square_real(s2 -. s1) /. (s0 +. -2.0 *. s1 +. s2), euler_transform (stream_cdr stream)) end let _ = take (euler_transform pi_stream) 8 let rec make_tableau transform stream = lazy (Node(stream, make_tableau transform (transform stream))) let accelerated_sequence transform stream = stream_map stream_car (make_tableau transform stream) let _ = take (accelerated_sequence euler_transform pi_stream) 8 (* Exercise 3.63 *) let sqrt_stream x = lazy (Node(1.0, stream_map (fun guess -> sqrt_improve guess x) (sqrt_stream x))) (* Exercise 3.64 *) (* exercise left to reader to define appropriate functions let sqrt x tolerance = stream_limit (sqrt_stream x) tolerance *) (* Infinite streams of pairs *) let rec stream_append s1 s2 = match Lazy.force s1 with | Empty -> s2 | Node(x, xs) -> lazy (Node(x, stream_append xs s2)) let rec interleave s1 s2 = match Lazy.force s1 with | Empty -> s2 | Node(x, xs) -> lazy (Node(x, interleave s2 xs)) let rec pairs s t = lazy begin Node([stream_car s; stream_car t], interleave (stream_map (fun x -> [stream_car s; x]) (stream_cdr t)) (pairs (stream_cdr s) (stream_cdr t))) end let _ = pairs integers integers let int_pairs = pairs integers integers let sop_gen () = stream_filter (fun pair -> isPrime((List.hd pair) + (List.hd (List.tl pair)))) int_pairs (* Exercise 3.68 *) (* CMR Error: Laziness not correct for this one - goes into infinite recursion *) let rec pairs s t = begin interleave (stream_map (fun x -> [stream_car s; x]) t) (pairs (stream_cdr s) (stream_cdr t)) end (* Streams as signals *) let integral integrand initial_value dt = let rec int_gen () = lazy (Node(initial_value, add_streams_real (scale_stream_real integrand dt) (int_gen()))) in int_gen() (* Exercise 3.74 *) (* exercise left to reader to define appropriate functions let rec make_zero_crossings input_stream last_value = lazy (Node(sign_change_detector (stream_car input_stream) last_value, make_zero_crossings (stream_cdr input_stream) (stream_cdr input_stream))) let zero_crossings = make_zero_crossings sense_data 0 *) (* Exercise 3.75 *) (* exercise left to reader to define appropriate functions let rec make_zero_crossings input_stream last_value = let avpt = (stream_car input_stream +. last_value) /. 2.0 in begin lazy (Node( sign_change_detector avpt last_value, make_zero_crossings (stream_cdr input_stream) avpt)) end *) ```

Chris Rathman / Chris.Rathman@tx.rr.com