About SICP The following F# 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 #02 Examples in F# *)
#light
(* Functions defined in previous chapters *)
let rec gcd a b =
   match b with
    | 0 -> a
    | b -> gcd b (a % b)

let rec fib n =
   match n with
    | 0 -> 0
    | 1 -> 1
    | n -> fib(n - 1) + fib(n - 2)

let identity x = x

(* Utility functions *)
(* Convert a list of characters to a string *)
let rec implode = function
   | [] -> ""
   | charlist -> String.of_char(List.hd charlist) ^ implode (List.tl charlist)

(* 2 Building Abstractions with Data *)
let linear_combination a b x y = a*x + b*y

let mulx = ( * )
let linear_combination' a b x y =
   mulx a x + mulx b y

(* 2.1.1 Introduction to Data Abstraction - Example: Arithmetic Operations for Rational Numbers *)

(* Literal Translation *)
let make_rat n d = [n; d]
let numer x = List.hd x
let denom x = List.hd(List.tl x)

let add_rat x y =
   make_rat ((numer x * denom y) + (numer y * denom x)) (denom x * denom y)
let sub_rat x y =
   make_rat ((numer x * denom y) - (numer y * denom x)) (denom x * denom y)
let mul_rat x y =
   make_rat (numer x * numer y) (denom x * denom y)
let div_rat x y =
   make_rat (numer x * denom y) (denom x * numer y)
let equal_rat x y =
   ((numer x * denom y) = (numer y * denom x))

let cons x y = [x; y]
let car = List.hd
let cdr = List.tl
let compose f g x = f(g x)
let cadr x = car(cdr x)

let x = cons 1 2
car x
cdr x

let x' = cons 1 2
let y = cons 3 4
let z = cons x' y
car(car z)
car(cdr z)

(* footnote -- alternative definitions *)
let make_rat'' = cons
let numer'' = car
let denom'' = cadr

let print_rat x =
   print_string ("\n" ^ (string_of_int (numer x)) ^ "/" ^ (string_of_int (denom x)))

let one_half = make_rat 1 2
print_rat one_half

let one_third = make_rat 1 3
print_rat (add_rat one_half one_third)
print_rat (mul_rat one_half one_third)
print_rat (add_rat one_third one_third)

(* reducing to lowest terms in constructor *)
let make_rat' n d =
   let g = gcd n d
   in [n / g; d / g]

let add_rat' x y =
   make_rat' ((numer x * denom y) + (numer y * denom x)) (denom x * denom y)

print_rat(add_rat' one_third one_third)
(* end Literal Translation *)

module sicp_module_translation =
(* Module Translation *)
   module Rational =
      struct
         type rational = int list
         let make_rat n d = [n; d]
         let numer x = List.hd x
         let denom x = List.hd(List.tl x)
         let add_rat x y =
            make_rat ((numer x * denom y) + (numer y * denom x)) (denom x * denom y)
         let sub_rat x y =
            make_rat ((numer x * denom y) - (numer y * denom x)) (denom x * denom y)
         let mul_rat x y =
            make_rat (numer x * numer y) (denom x * denom y)
         let div_rat x y =
            make_rat (numer x * denom y) (denom x * numer y)
         let equal_rat x y =
            ((numer x * denom y) = (numer y * denom x))
         let print_rat x =
            print_string ("\n" ^ string_of_int (numer x) ^ "/" ^ string_of_int  (denom x))
      end

   let one_half = Rational.make_rat 1 2
   Rational.print_rat one_half

   let one_third = Rational.make_rat 1 3
   Rational.print_rat (Rational.add_rat one_half one_third)
   Rational.print_rat (Rational.mul_rat one_half one_third)
   Rational.print_rat (Rational.add_rat one_third one_third)

   (* reducing to lowest terms in constructor *)
   module Rational' =
      struct
         type rational = int list
         let make_rat n d =
            let g = gcd n d
            in [n / g; d / g]
         let numer x = List.hd x
         let denom x = List.hd(List.tl x)
         let add_rat x y =
            make_rat ((numer x * denom y) + (numer y * denom x)) (denom x * denom y)
         let sub_rat x y =
            make_rat ((numer x * denom y) - (numer y * denom x)) (denom x * denom y)
         let mul_rat x y =
            make_rat (numer x * numer y) (denom x * denom y)
         let div_rat x y =
            make_rat (numer x * denom y) (denom x * numer y)
         let equal_rat x y =
            ((numer x * denom y) = (numer y * denom x))
         let print_rat x =
            print_string ("\n" ^ string_of_int (numer x) ^ "/" ^ string_of_int (denom x))
      end

   let one_third' = Rational'.make_rat 1 3
   Rational'.print_rat (Rational'.add_rat one_third' one_third')
(* end Module Translation *)

module sicp_object_translation =
(* Object Translation *)
   type Rational(n, d) =
      class
         member x.numer = n
         member x.denom = d
         member x.add_rat (other : Rational) =
            new Rational(x.numer * other.denom + other.numer * x.denom, x.denom * other.denom)
         member x.sub_rat (other : Rational) =
            new Rational(x.numer * other.denom - other.numer * x.denom, x.denom * other.denom)
         member x.mul_rat (other : Rational) =
            new Rational(x.numer * other.numer, x.denom * other.denom)
         member x.div_rat (other : Rational) =
            new Rational(x.numer * other.denom, x.denom * other.numer)
         member x.equal_rat (other : Rational) =
            ((x.numer * other.denom) = (other.numer * x.denom))
         member x.print_rat () =
            print_string ("\n" ^ string_of_int (x.numer) ^ "/" ^ string_of_int (x.denom))
      end

   let one_half = new Rational(1, 2)
   one_half.print_rat()

   let one_third = new Rational(1, 3)
   (one_half.add_rat one_third).print_rat()
   (one_half.mul_rat one_third).print_rat()
   (one_third.add_rat one_third).print_rat()

   (* reducing to lowest terms in constructor *)
   type Rational' (n, d) =
      class
         let g = gcd n d
         member x.numer = n / g
         member x.denom = d / g
         member x.add_rat (other : Rational') =
            new Rational(x.numer * other.denom + other.numer * x.denom, x.denom * other.denom)
         member x.sub_rat (other : Rational') =
            new Rational(x.numer * other.denom - other.numer * x.denom, x.denom * other.denom)
         member x.mul_rat (other : Rational') =
            new Rational(x.numer * other.numer, x.denom * other.denom)
         member x.div_rat (other : Rational') =
            new Rational(x.numer * other.denom, x.denom * other.numer)
         member x.equal_rat (other : Rational') =
            ((x.numer * other.denom) = (other.numer * x.denom))
         member x.print_rat () =
            print_string ("\n" ^ string_of_int (x.numer) ^ "/" ^ string_of_int (x.denom))
      end

   let one_third' = new Rational'(1, 3)
   (one_third'.add_rat one_third').print_rat()
(* end Object Translation *)

(* Exercise 2.1 *)
let make_rat''' n d =
   if (d < 0 && n < 0) || n < 0
      then [-d; -n]
      else [d; n]

(* 2.1.2 Introduction to Data Abstraction - Abstraction barriers *)

module sicp_literal_translation' =
(* Literal Translation *)
   (* reducing to lowest terms in selectors *)
   let make_rat n d = cons n d

   let numer x =
      let g = gcd (car x) (cadr x)
      in car x / g
   let denom x =
      let g = gcd (car x) (cadr x)
      in cadr x / g
(* end Literal Translation *)

module sicp_module_translation' =
(* Module Translation *)
   (* reducing to lowest terms in selectors *)
   module Rational =
      struct
         type rational = int list
         let make_rat n d = [n; d]
         let numer x =
            let n = List.hd x
            and d = List.hd (List.tl x)
            in n / (gcd n d)
         let denom x =
            let n = List.hd x
            and d = List.hd(List.tl x)
            in d / (gcd n d)
         let add_rat x y =
            make_rat ((numer x * denom y) + (numer y * denom x)) (denom x * denom y)
         let sub_rat x y =
            make_rat ((numer x * denom y) - (numer y * denom x)) (denom x * denom y)
         let mul_rat x y =
            make_rat (numer x * numer y) (denom x * denom y)
         let div_rat x y =
            make_rat (numer x * denom y) (denom x * numer y)
         let equal_rat x y =
            ((numer x * denom y) = (numer y * denom x))
         let print_rat x =
            print_string ("\n" ^ string_of_int (numer x) ^ "/" ^ string_of_int  (denom x))
      end
(* end Module Translation *)

module sicp_object_translation' =
(* Object Translation *)
   (* reducing to lowest terms in selectors *)
   type Rational(n, d) =
      class
         member x.numer = n / gcd n d
         member x.denom = d / gcd n d
         member x.add_rat (other : Rational) =
            new Rational(x.numer * other.denom + other.numer * x.denom, x.denom * other.denom)
         member x.sub_rat (other : Rational) =
            new Rational(x.numer * other.denom - other.numer * x.denom, x.denom * other.denom)
         member x.mul_rat (other : Rational) =
            new Rational(x.numer * other.numer, x.denom * other.denom)
         member x.div_rat (other : Rational) =
            new Rational(x.numer * other.denom, x.denom * other.numer)
         member x.equal_rat (other : Rational) =
            ((x.numer * other.denom) = (other.numer * x.denom))
         member x.print_rat () =
            print_string ("\n" ^ string_of_int (x.numer) ^ "/" ^ string_of_int (x.denom))
      end
(* end Object Translation *)

(* Exercise 2.2 *)
let make_point x y = [x; y]
let x_point point = List.hd point
let y_point point = List.hd(List.tl point)
let make_segment start_segment end_segment = [start_segment; end_segment]
let start_segment' segment = List.hd segment
let end_segment' segment = List.hd(List.tl segment)
let midpoint_segment segment =
   let s = start_segment' segment
   and e = end_segment' segment
   in make_point ((x_point s + x_point e) / 2.0) ((y_point s + y_point e) / 2.0)
let print_point p =
   print_string ("\n" ^ "(" ^ string_of_float (x_point p) ^ "," ^ string_of_float (y_point p) ^ ")")

(* Exercise 2.3 *)
let square_float x = x * x
let length_segment segment =
   let s = start_segment' segment
   and e = end_segment' segment
   in sqrt(square_float(x_point e - x_point s) + square_float(y_point e - y_point s))

(* Constructors create type tagged using  *)
type 'a axy = { anchor:'a; xlen:'a; ylen:'a }
type 'a seg = { start_segment:'a; end_segment:'a }
type 'a rectangle = Axy of 'a axy
                  | Seg of 'a seg
let make_rectangle anchor xlen ylen =
   Axy {anchor=anchor; xlen=xlen; ylen=ylen}
let make_rectangle' start_segment end_segment =
   Seg {start_segment=start_segment; end_segment=end_segment}

(* 'length_rectangle' and 'width_rectangle' act as an abstraction barrier for higher-level
   procedures because 'rectangle' implementation details are buried here, and should the
   implementation change, only these procedures will need to be altered to support the change *)
let length_rectangle rect =
   match rect with
    | Axy {anchor=anchor; xlen=xlen; ylen=ylen} -> 0.0                     (* Compute length ... *)
    | Seg {start_segment=start_segment; end_segment=end_segment} -> 0.0    (* Compute length ... *)

let width_rectangle rect =
   (* As per 'length_rectangle' except that rectangle width is returned ... *)
   0.0

(* High-level procedures are quarantined from representation / implementation details *)
let area_rectangle rect =
   (length_rectangle rect) * (width_rectangle rect)

let perimeter_rectangle rect =
   (length_rectangle rect) * 2.0 + (width_rectangle rect) * 2.0

(* 2.1.3 Introduction to Data Abstraction - What is meant by data? *)

exception IllFormedExpr of string
let cons' x y m =
   match m with
    | 0 -> x
    | 1 -> y
    | _ -> raise (IllFormedExpr ("Argument not 0 or 1 -- CONS " ^ string_of_int m))

let car' z = z 0
let cdr' z = z 1

(* Exercise 2.4 *)
let cons'' x y m = m x y
let car'' z = z (fun p q -> p)
let cdr'' z = z (fun p q -> q)

(* Exercise 2.5 *)
let rec power x k =
   match k with
    | 0 -> 1
    | 1 -> x
    | _ -> x * power x (k-1)
let cons''' x y =
   power 2 (x * power 3 y)
let rec car''' z =
   if (z % 2) = 0
      then car''' ((z / 2) + 1)
      else 0
let rec cdr''' z =
   if (z % 3) = 0
      then cdr''' ((z / 3) + 1)
      else 0

(* Exercise 2.6 *)
let zero f x = x
let add1 n f x = f (n f x)

(* 2.1.4 Introduction to Data Abstraction - Extended Exercise: Interval Arithmetic *)

(* Literal Translation *)
let make_interval a b = (a, b)

let lower_bound (x, y) = x
let upper_bound (x, y) = y

let add_interval x y =
   make_interval (lower_bound x + lower_bound y) (upper_bound x + upper_bound y)

let mul_interval x y =
   let p1 = lower_bound x * lower_bound y
   and p2 = lower_bound x * upper_bound y
   and p3 = upper_bound x * lower_bound y
   and p4 = upper_bound x * upper_bound y
   in make_interval
      (min (min p1 p2) (min p3 p4))
      (max (max p1 p2) (max p3 p4))

let div_interval x y =
   let z = make_interval (1.0 / upper_bound y) (1.0 / lower_bound y)
   in mul_interval x z

let make_center_width c w =
   make_interval (c - w) (c + w)

let center i =
   (lower_bound i + upper_bound i) / 2.0

let width i =
   (upper_bound i - lower_bound i) / 2.0

(* parallel resistors *)
let par1 r1 r2 =
   div_interval (mul_interval r1 r2) (add_interval r1 r2)

let par2 r1 r2 =
   let one = make_interval 1.0 1.0
   in div_interval
      one
      (add_interval (div_interval one r1) (div_interval one r2))
(* end Literal Translation *)

module sicp_module_translation'' =
(* Module Translation *)
   module Interval =
      struct
         type interval = float * float
         let make_interval a b = (a, b)
         let lower_bound (x, y) = x
         let upper_bound (x, y) = y
         let add_interval x y =
            make_interval (lower_bound x + lower_bound y) (upper_bound x + upper_bound y)
         let mul_interval x y =
            let p1 = lower_bound x * lower_bound y
            and p2 = lower_bound x * upper_bound y
            and p3 = upper_bound x * lower_bound y
            and p4 = upper_bound x * upper_bound y
            in make_interval
               (min (min p1 p2) (min p3 p4))
               (max (max p1 p2) (max p3 p4))
         let div_interval x y =
            let z = make_interval (1.0 / upper_bound y) (1.0 / lower_bound y)
            in mul_interval x z
         let make_center_width c w =
            make_interval (c - w) (c + w)
         let center i =
            (lower_bound i + upper_bound i) / 2.0
         let width i =
            (upper_bound i - lower_bound i) / 2.0
      end

   (* parallel resistors *)
   let par1 r1 r2 =
      Interval.div_interval (Interval.mul_interval r1 r2) (Interval.add_interval r1 r2)

   let par2 r1 r2 =
      let one = Interval.make_interval 1.0 1.0
      in Interval.div_interval
         one
         (Interval.add_interval (Interval.div_interval one r1)
                                (Interval.div_interval one r2))
(* end Module Translation *)

module sicp_object_translation'' =
(* Object Translation *)
   type Interval(a, b) =
      class
         member x.lower_bound = a
         member y.upper_bound = b
         member x.add_interval (other : Interval) =
            new Interval(x.lower_bound + other.lower_bound, x.upper_bound + other.upper_bound)
         member x.mul_interval (other : Interval) =
            let p1 = x.lower_bound * other.lower_bound
            and p2 = x.lower_bound * other.upper_bound
            and p3 = x.upper_bound * other.lower_bound
            and p4 = x.upper_bound * other.upper_bound
            in new Interval(min (min p1 p2) (min p3 p4), max (max p1 p2) (max p3 p4))
         member x.div_interval (other : Interval) =
            let z = new Interval(1.0 / other.upper_bound, 1.0 / other.lower_bound)
            in x.mul_interval z
         member x.make_center_width c w =
            new Interval(c - w, c + w)
         member x.center =
            (x.lower_bound + x.upper_bound) / 2.0
         member x.width =
            (x.upper_bound - x.lower_bound) / 2.0
      end

   (* parallel resistors *)
   let par1 (r1 : Interval) (r2 : Interval) =
      (r1.mul_interval r2).div_interval(r1.add_interval r2)

   let par2 r1 r2 =
      let one = new Interval(1.0, 1.0)
      in one.div_interval((one.div_interval r1).add_interval(one.div_interval r2))
(* end Object Translation *)

(* Exercise 2.7 *)
let make_interval' a b = (a, b)
let lower_bound' (x, y) = x
let upper_bound' (x, y) = y

(* Exercise 2.8 *)
let sub_interval x y =
   make_interval (lower_bound x - lower_bound y) (upper_bound x - upper_bound y)

(* Exercise 2.9 *)
let i = make_interval 5.0 10.0
let j = make_interval 15.0 25.0

(* width of the sum (or difference) of two intervals *is* a function only of the widths of
   the intervals being added (or subtracted) *)
let _ = (width (add_interval i j), (width i + width j))
let _ = (width (sub_interval i j), (width i + width j))

(* width of the product (or quotient) of two intervals *is not* a function only of the widths
   of the intervals being multiplied (or divided) *)
let _ = (width (mul_interval i j), (width i + width j))
let _ = (width (div_interval i j), (width i + width j))

(* Exercise 2.10 *)
exception DivideByZero of string
let is_zero_interval i =
   lower_bound i = 0.0 || upper_bound i = 0.0
let div_interval_zero_check x y =
   if is_zero_interval y
      then raise (DivideByZero("Zero interval divisor"))
      else div_interval x y

(* Exercise 2.12 *)
let make_center_percent c p =
   make_center_width c (p * c / 100.0)
let percent i =
   width i / (center i) * 100.0

(* 2.2.1 Hierarchical Data and the Closure Property - Representing Sequences *)

let _ = 1::2::3::4::[]
let one_through_four = [1; 2; 3; 4]

one_through_four
List.hd one_through_four
List.tl one_through_four
List.hd (List.tl one_through_four)
10::one_through_four

(* List.nth *)
let rec list_ref items n =
   match items, n with
    | x::xs, 0 -> x
    | x::xs, n -> list_ref xs (n-1)
    | [], _ -> failwith "Empty List"

let squares = [1; 4; 9; 16; 25]
list_ref squares 3

let length items =
   let rec length_iter items count =
      match items with
       | [] -> count
       | x::xs -> length_iter xs (1+count)
   in length_iter items 0

(* Alternate definition *)
let rec length' =
   function
    | [] -> 0
    | x::xs -> 1 + length' xs

let odds = [1; 3; 5; 7]
length' odds

(* From OCaml stdlib: *)
let rec length_aux len =
   function
    | [] -> len
    | a::l -> length_aux (len + 1) l

let length'' l = length_aux 0 l

let rec append list1 list2 =
   match list1 with
    | [] -> list2
    | x::xs -> x :: append xs list2

append squares odds
append odds squares

(* Mapping over lists *)
let rec scale_list factor items =
   match items with
    | [] -> []
    | x::xs -> x * factor :: scale_list factor xs

scale_list 10 [1; 2; 3; 4; 5]

let rec map f items =
   match items with
    | [] -> []
    | x::xs -> f x :: map f xs

(* Alternate definition *)
let rec map' f = function
  | [] -> []
  | x::xs -> f x :: map' f xs

map' abs_float [-10.0; 2.5; -11.6; 17.0]

map (fun x -> x * x) [1; 2; 3; 4]

let scale_list' factor items =
   map (fun x -> x * factor) items

List.map2 ( + ) [40;50;60] [700;800;900]
List.map2 (fun x y -> x+2*y) [1;2;3] [4;5;6]

(* Exercise 2.17 *)
let rec last_pair = function
  | [h1;h2] -> h1, h2
  | x::xs -> last_pair xs
  | [] -> invalid_arg "last_pair"
last_pair [23; 72; 149; 34]

(* Exercise 2.18 *)
let rec reverse items =
   match items with
    | [] -> []
    | x::xs -> append (reverse xs) [x]
reverse [1; 4; 9; 16; 25]
let reverse' items =
   let rec reverse_iter items accum =
      match items with
       | [] -> accum
       | x::xs -> reverse_iter xs (x::accum)
   in reverse_iter items []
reverse' [1; 4; 9; 16; 25]

(* Exercise 2.19 *)
let no_more coin_values =
   match coin_values with
    | [] -> true
    | x::xs -> false
let except_first_denomination coin_values = List.tl coin_values
let first_denomination coin_values = List.hd coin_values
let rec cc amount coin_values =
   if amount = 0
      then 1
      else
         if amount < 0 || no_more coin_values
            then 0
            else
               (cc amount (except_first_denomination coin_values)) +
               (cc (amount - first_denomination coin_values) coin_values)
let us_coins = [50; 25; 10; 5; 1]
cc 100 us_coins
(* Note: F# doesn't like mixing ints and floats (answer should be 104561) *)
(* let uk_coins = [100; 50; 20; 10; 5; 2; 1; 0.5] *)
(* cc 100 uk_coins *)

(* Exercise 2.20 *)
let rec filter predicate items =
   match items with
    | [] -> []
    | x::xs ->
      if predicate x
         then x :: filter predicate xs
         else filter predicate xs
let isOdd n = (n % 2 = 1)
let isEven = compose not isOdd
let same_parity xs =
   let predicate = if isOdd (List.hd xs) then isOdd else isEven
   in filter predicate (List.tl xs)
same_parity [1; 2; 3; 4; 5; 6; 7]
same_parity [2; 3; 4; 5; 6; 7]

(* Exercise 2.21 *)
let rec square_list items =
   match items with
    | [] -> []
    | x::xs ->  x*x :: square_list xs
square_list [1; 2; 3; 4]
let square_list_1 items =
   map (fun x -> x*x) items
square_list_1 [1; 2; 3; 4]

(* Exercise 2.22 *)
let square x = x * x
let square_list_2 list = map square list
let square_list_3 items =
   let rec iter things answer =
      match things with
       | [] -> answer
       | x::xs -> iter xs (square x::answer)
   in iter items []
square_list_3 [1; 2; 3; 4]
let square_list_4 items =
   let rec iter things answer =
      match things with
       | [] -> answer
       | x::xs -> iter xs (answer @ [square x])
   in iter items []
square_list_4 [1; 2; 3; 4]
let square_list_5 items =
   let rec iter things answer =
      match things with
       | [] -> answer
       | x::xs -> iter xs (square x::answer)
   in reverse (iter items [])
square_list_5 [1; 2; 3; 4]

(* Exercise 2.23 *)
(* See also List.iter *)
let rec for_each items f =
   match items with
    | [] -> ()
    | x::xs -> let _ = f x in for_each xs f
for_each [57; 321; 88] (fun x -> print_string ("\n" ^ (string_of_int x)));

(* 2.2.2 Hierarchical Data and the Closure Property - Hierarchical Structures *)

type 'a nestedlist = Leaf of 'a
                   | Node of 'a nestedlist list

let rec length''' = function
  | Node list -> length list
  | Leaf _ -> 1

Node[Node[Leaf 1; Leaf 2]; Node[Leaf 3; Leaf 4]]
let xa = Node[Node[Leaf 1; Leaf 2]; Node[Leaf 3; Leaf 4]]
length''' xa

let rec count_leaves = function
  | Node [] -> 0
  | Node(x::xs) -> count_leaves x + count_leaves(Node xs)
  | Leaf x -> 1

let xb = Node[Node[Leaf 1; Leaf 2]; Node[Leaf 3; Leaf 4]]
length''' xb
count_leaves xb

Node[xb; xb]
length''' (Node[xb; xb])
count_leaves (Node[xb; xb])

(* Mapping over trees *)
let rec scale_tree factor tree =
   match tree with
    | Leaf x -> Leaf (x * factor)
    | Node [] -> Node []
    | Node (x::xs) ->
         let a = scale_tree factor (Node xs) in
         let b =
            match a with
             | Node c -> c
             | Leaf c -> [Leaf c]
         in Node ((scale_tree factor x) :: b)

scale_tree 10 (Node[Leaf 1; Node[Leaf 2; Node[Leaf 3; Leaf 4]; Leaf 5]; Node[Leaf 6; Leaf 7]])

let rec scale_tree' factor tree =
   match tree with
    | Leaf x -> Leaf (x * factor)
    | Node x -> Node(map (scale_tree' factor) x)

(* Exercise 2.24 *)
Node[Leaf 1; Node[Leaf 2; Node[Leaf 3; Leaf 4]]]

(* Exercise 2.25 *)
Node[Leaf 1; Leaf 3; Node[Leaf 5; Leaf 7]; Leaf 9]
Node[Node[Leaf 7]]
Node[Leaf 1; Node[Leaf 2; Node[Leaf 3; Node[Leaf 4; Node[Leaf 5; Node[Leaf 6; Leaf 7]]]]]]

(* Exercise 2.26 *)
let xc = Node[Leaf 1; Leaf 2; Leaf 3]
let yc = Node[Leaf 4; Leaf 5; Leaf 6]
let rec append_tree tree1 tree2 =
   match tree1, tree2 with
    | Node x, Leaf y -> Node (x @ [Leaf y])
    | Leaf x, Node y -> Node ((Leaf x)::y)
    | Node x, Node y -> Node (x @ y)
    | Leaf x, Leaf y -> Node [Leaf x; Leaf y]
append_tree xc yc
Node[xc; Node[yc]]
Node[xc; yc]

(* Exercise 2.27 *)
let xd = Node[Node[Leaf 1; Leaf 2]; Node[Leaf 3; Leaf 4]]
let reverse'' tree =
   match tree with
    | Leaf x  -> Leaf x
    | Node xs -> Node (List.rev xs)
reverse'' xd
let rec deep_reverse tree =
   match tree with
    | Leaf x  -> Leaf x
    | Node xs -> Node (List.rev (map deep_reverse xs))
deep_reverse xd

(* Exercise 2.28 *)
let xe = Node[Node[Leaf 1; Leaf 2]; Node[Leaf 3; Leaf 4]]
let rec fringe tree =
   match tree with
    | Leaf x -> [x]
    | Node [] -> []
    | Node (x::xs) -> fringe x @ fringe (Node xs)
fringe xe
fringe(Node[xe; xe])

(* Exercise 2.29 *)
(* a. *)
let make_mobile left right = Node[left; right]
let make_branch length struc = Node[Leaf length; struc]
let left_branch tree =
   match tree with
    | Node[left; right] -> left
    | _ -> failwith "Error"
let right_branch tree =
   match tree with
    | Node[left; right] -> right
    | _ -> failwith "Error"
let branch_length tree =
   match tree with
    | Node[Leaf length; struc] -> length
    | _ -> failwith "Error"
let branch_structure tree =
   match tree with
    | Node[Leaf length; struc] -> struc
    | _ -> failwith "Error"
(* Remainder To Be Done *)

(* Exercise 2.30 *)
let rec square_tree tree =
   match tree with
    | Leaf x  -> Leaf (x*x)
    | Node xs -> Node(map square_tree xs)
square_tree
   (Node[Leaf 1;
      Node[Leaf 2; Node[Leaf 3; Leaf 4]; Leaf 5];
      Node[Leaf 6; Leaf 7]])

(* Exercise 2.31 *)
let rec tree_map proc tree =
   match tree with
    | Leaf x  -> Leaf(proc x)
    | Node xs -> Node(map (tree_map proc) xs)
let square_tree' tree = tree_map square tree
square_tree'(Node[Leaf 1;
              Node[Leaf 2; Node[Leaf 3; Leaf 4]; Leaf 5];
              Node[Leaf 6; Leaf 7]])

(* Exercise 2.32 *)
let rec subsets s =
   match s with
    | [] -> [[]]
    | x::xs ->
      let rest = subsets xs
      in rest @ (map (fun y -> x::y) rest)
subsets [1; 2; 3]

(* 2.2.3 Hierarchical Data and the Closure Property - Sequences as Conventional Interfaces *)

let isOdd' n = (n % 2 = 1)
let isEven' = compose not isOdd
let square' x = x * x

let rec sum_odd_squares tree =
   match tree with
    | Node [] -> 0
    | Leaf x when isOdd x-> square x
    | Leaf x -> 0
    | Node(x::xs) -> sum_odd_squares x + sum_odd_squares(Node xs)

let rec even_fibs n =
   let rec next k =
      if k > n
         then []
         else
            let f = fib k
            in
               if isEven f
                  then f::next(k+1)
                  else next(k+1)
   in next 0

(* Sequence operations *)
map square [1;2;3;4;5]

let rec filter' f = function
  | [] -> []
  | x::xs when f x -> x::filter' f xs
  | x::xs -> filter' f xs

filter' isOdd [1;2;3;4;5]

(* This is just List.fold_right *)
let rec accumulate f accu = function
  | [] -> accu
  | x::xs -> f x (accumulate f accu xs)

accumulate ( + ) 0 [1;2;3;4;5]
accumulate ( * ) 1 [1;2;3;4;5]
accumulate (fun x y -> x::y) [] [1;2;3;4;5]

let rec enumerate_interval low high =
   if low > high
      then []
      else low :: enumerate_interval (low+1) high

enumerate_interval 2 7

let rec enumerate_tree tree =
   match tree with
    | Node [] -> []
    | Leaf x -> [x]
    | Node (x::xs) -> enumerate_tree x @ enumerate_tree (Node xs)

enumerate_tree (Node[Leaf 1; Node[Leaf 2; Node[Leaf 3; Leaf 4]; Leaf 5]])

let sum_odd_squares' tree =
   accumulate (+) 0 (map square (filter isOdd (enumerate_tree tree)))

let even_fibs' n =
   accumulate (fun x y -> x::y) [] (filter isEven (map fib (enumerate_interval 0 n)))

let list_fib_squares n =
   accumulate (fun x y -> x::y) [] (map square (map fib (enumerate_interval 0 n)))

list_fib_squares 10

let product_of_squares_of_odd_elements sequence =
   accumulate ( * ) 1 (map square (filter isOdd sequence))

product_of_squares_of_odd_elements [1;2;3;4;5]

type employee = { name:string; jobtitle:string; salary:int }
let isProgrammer emp = (emp.jobtitle = "Programmer")
let salary emp = emp.salary
let salary_of_highest_paid_programmer records =
   accumulate (max) 0 (map salary (filter isProgrammer records))

let recs = [{name="Fred"; jobtitle="Programmer"; salary=180};
            {name="Hank"; jobtitle="Programmer"; salary=150}]
salary_of_highest_paid_programmer recs

(* Nested mappings *)
let n = 10                   (* book doesn't define n *)
accumulate (@) []
   (map
      (fun i -> map (fun j -> [i; j]) (enumerate_interval 1 (i-1)))
      (enumerate_interval 1 n))

let flatmap proc seq = accumulate (@) [] (map proc seq)

let rec has_no_divisors n c =
   c = 1 || (n % c <> 0 && has_no_divisors n (c-1))

let isPrime n = has_no_divisors n (n-1)

(* Unnecessary run-time checks can be replaced by lists with statically-known lengths (tuples). *)
let prime_sum (x, y) = isPrime (x + y)

let make_pair_sum (x, y) = (x, y, x+y)

let prime_sum_pairs n =
   map make_pair_sum
      (filter
         prime_sum
         (flatmap
            (fun i -> map (fun j -> i, j) (enumerate_interval 1 (i-1)))
            (enumerate_interval 1 n)))

let remove x list =
   filter (( <> ) x) list

let rec permutations = function
 | [] -> [[]]
 | s ->
      flatmap
         (fun x -> map (fun p -> x::p) (permutations (remove x s)))
         s

(* Exercise 2.34 *)
(* exercise left to reader to define appropriate functions
   let horner_eval x coefficient_sequence =
      accumulate (fun this_coeff higher_terms -> ??FILL_THIS_IN??) 0 coefficient_sequence
   horner_eval 2 [1;3;0;5;0;1] *)

(* Exercise 2.36 *)
(* exercise left to reader to define appropriate functions
   let accumulate_n oper init segs =
      if (segs = [])
         then []
         else
            (accumulate oper init ??FILL_THIS_IN??)::
            (accumulate_n oper init ??FILL_THIS_IN??)
   accumulate_n (+) 0 s *)

(* CMR Error - need to finish this one *)
(* Exercise 2.37 *
let dot_product(v, w) =
   accumulate
      op+
      0
      (map
            (fn i =>
               map
                  (fn j => i * j)
                  w)
            v)
let dot_product v w = fold_left ( + ) (List.map2 ( * ) v w)
*)

(* Exercise 2.38 *)
let fold_right = accumulate
let fold_left oper initial sequence =
   let rec iter result seq =
      match seq with
       | [] -> result
       | x::xs -> iter (oper result x) xs
   in iter initial sequence

fold_right (/) 1.0 [1.0;2.0;3.0]
fold_left (/) 1.0 [1.0;2.0;3.0]
fold_right (fun x y -> x::y) [] [1;2;3]
(* CMR Error - won't compile - Scheme result = (((() 1) 2) 3) *)
(* The result is not a valid list. -- jdh *)
(* fold_left (fun x y -> x::y) [] [1;2;3] *)

(* Exercise 2.42 *)
let na=8
let rec safe (x1, y1) (x2, y2) =
   x1 <> x2 && y1 <> y2 && x2 - x1 <> y2 - y1 && x1 - y2 <> x2 - y1
let rec search f n qs ps accu =
   match ps with
    | [] -> if length qs = n then f qs accu else accu
    | q::ps -> search f n (q::qs) (filter (safe q) ps) (search f n qs ps accu)
let rec init n f = if n=0 then [] else f(n-1) :: init (n-1) f
let ps = List.flatten (init na (fun i -> init na (fun j -> i, j)))
(* search (fun qs -> print qs; (+) 1) n 0 [] ps 0 *)
(* exercise left to reader to define appropriate functions
   let queens board_size =
      let queen_cols k =
         if (k = 0)
            then[empty_board]
            else
               filter
                  (fun positions -> isSafe k positions)
                  (flatmap
                     (fun rest_of_queens -> map
                        (fun new_row -> adjoin_position new_row k rest_of_queens)
                        (enumerate_interval 1 board_size))
                     (queen_cols (k-1)))
      in queen_cols board_size *)

(* Exercise 2.43 *)
(* exercise left to reader to define appropriate functions
   let queens board_size =
      let queen_cols k
         if (k = 0)
            then [empty_board]
            else
               filter
                  (fun positions -> isSafe k positions)
                  (flatmap
                     (fun new_row -> map
                        (fun rest_of_queens -> adjoin_position new_row k rest_of_queens)
                        (queen_cols (k-1)))
                     (enumerate_interval 1 board_size))
      in queen_cols board_size *)

(* 2.2.4 Hierarchical Data and the Closure Property - Example: a picture language *)

(* these two routines are to be written *)
let draw_line x y = ()
let wave xframe = xframe

type vect_rec = { x:float; y:float }
type vect = Vect of vect_rec

let make_vect x y = Vect{x=x; y=y}
let xcor_vect (Vect{x=x}) = x
let ycor_vect (Vect{y=y}) = y
let add_vect v1 v2 = make_vect (xcor_vect v1 + xcor_vect v2) (ycor_vect v1 + ycor_vect v2)
let sub_vect v1 v2 = make_vect (xcor_vect v1 - xcor_vect v2) (ycor_vect v1 - ycor_vect v2)
let scale_vect s v = make_vect (s * (xcor_vect v)) (s * (ycor_vect v))

type frame_rec = { origin:vect; edge1:vect; edge2:vect }
type frame = Frame of frame_rec
let make_frame origin edge1 edge2 = Frame{origin=origin; edge1=edge1; edge2=edge2}
let origin_frame (Frame{origin=origin}) = origin
let edge1_frame (Frame{edge1=edge1}) = edge1
let edge2_frame (Frame{edge2=edge2}) = edge2
let a_frame = make_frame (make_vect 0.0 0.0) (make_vect 1.0 0.0) (make_vect 0.0 1.0)

type 'a segment_record = { x:'a; y:'a }
type 'a segment = Segment of 'a segment_record
let start_segment (Segment{x=x}) = x
let end_segment (Segment{y=y}) = y

(* Frames *)
let frame_coord_map xframe v =
   add_vect
      (origin_frame xframe)
      (add_vect
         (scale_vect (xcor_vect v) (edge1_frame xframe))
         (scale_vect (ycor_vect v) (edge2_frame xframe)))

let _ = frame_coord_map a_frame (make_vect 0.0 0.0)
let _ = origin_frame a_frame

(* Painters *)
let rec foreach f items =
   match items with
    | [] -> ()
    | x::xs -> let _ = f x in foreach f xs

let segments_painter segment_list xframe =
   foreach
      (fun segment ->
         draw_line
            (frame_coord_map xframe (start_segment segment))
            (frame_coord_map xframe (end_segment segment)))
      segment_list

let transform_painter painter origin corner1 corner2 xframe =
   let m = frame_coord_map xframe in
   let new_origin = m origin
   in painter
         (make_frame
            new_origin
            (sub_vect (m corner1) new_origin)
            (sub_vect (m corner2) new_origin))

let flip_vert painter =
   transform_painter
      painter
      (make_vect 0.0 1.0)
      (make_vect 1.0 1.0)
      (make_vect 0.0 0.0)

let flip_horiz painter =
   transform_painter
      painter
      (make_vect 1.0 0.0)
      (make_vect 0.0 0.0)
      (make_vect 1.0 1.0)

let shrink_to_upper_right painter =
   transform_painter
      painter
      (make_vect 0.5 0.5)
      (make_vect 1.0 0.5)
      (make_vect 0.5 1.0)

let rotate90 painter =
   transform_painter
      painter
      (make_vect 1.0 0.0)
      (make_vect 1.0 1.0)
      (make_vect 0.0 0.0)

let rotate180 painter =
   transform_painter
      painter
      (make_vect 1.0 1.0)
      (make_vect 0.0 1.0)
      (make_vect 1.0 0.0)

let squash_inwards painter =
   transform_painter
      painter
      (make_vect 0.0 0.0)
      (make_vect 0.65 0.35)
      (make_vect 0.35 0.65)

let beside painter1 painter2 xframe =
   let split_point = make_vect 0.5 0.0 in
   let paint_left =
      transform_painter
         painter1
         (make_vect 0.0 0.0)
         split_point
         (make_vect 0.0 1.0)
   and paint_right =
      transform_painter
         painter2
         split_point
         (make_vect 1.0 0.0)
         (make_vect 0.5 1.0)
   in
      let _ = paint_left xframe
      in paint_right xframe

let below painter1 painter2 xframe =
   let split_point = make_vect 0.0 0.5 in
   let paint_below =
      transform_painter
         painter1
         (make_vect 0.0 0.0)
         (make_vect 1.0 0.0)
         split_point
   and paint_above =
      transform_painter
         painter2
         split_point
         (make_vect 1.0 0.5)
         (make_vect 0.0 1.0)
   in
      let _ = paint_below xframe
      in paint_above xframe

let rec up_split painter n =
   if n = 0
      then painter
      else
         let smaller = up_split painter (n-1)
         in below painter (beside smaller smaller)

let wave2 = beside wave (flip_vert wave)

let wave4 = below wave2 wave

let flipped_pairs painter =
   let painter2 = beside painter (flip_vert painter)
   in below painter2 painter2

let wave4' = flipped_pairs wave

let rec right_split painter n =
   if n = 0
      then painter
      else
         let smaller = right_split painter (n-1)
         in beside painter (below smaller smaller)

let rec corner_split painter n =
   if n = 0
      then painter
      else
         let up = up_split painter (n-1)
         and right = right_split painter (n-1) in
         let top_left = beside up up
         and bottom_right = below right right
         and corner = corner_split painter (n-1)
         in beside (below painter top_left) (below bottom_right corner)

let square_limit painter n =
   let quarter = corner_split painter n in
   let half = beside (flip_horiz quarter) quarter
   in below (flip_vert half) half

(* Higher_order operations *)
let square_of_four tleft tright bleft bright =
   fun painter ->
      let top = beside (tleft painter) (tright painter)
      and bottom = beside (bleft painter) (bright painter)
      in below bottom top

let flipped_pairs' painter =
   let combine4 = square_of_four identity flip_vert identity flip_vert
   in combine4 painter

(* footnote *)
(* CMR Error - let flipped_pairs'' = square_of_four identity flip_vert identity flip_vert *)

let square_limit' painter n =
   let combine4 = square_of_four flip_horiz identity rotate180 flip_vert
   in combine4 (corner_split painter n)

(* Exercise 2.45 *)
(* exercise left to reader to define appropriate functions
   let right_split = split beside below
   let up_split = split below beside *)

(* Exercise 2.47 *)
let make_frame' origin edge1 edge2 = [origin; edge1; edge2]
let make_frame'' origin edge1 edge2 = [origin; [edge1; edge2]]

(* 2.3.1 Symbolic Data - Quotation *)
let _ = ["a"; "b"; "c"; "d"]
let _ = [23; 45; 17]
type person_record = { name:string; age:int }
let _ = [{name="Norah"; age=12}; {name="Molly"; age=9}; {name="Anna"; age=7}; {name="Charlotte"; age=3}]

let xf = 1
let _ = (23 + 45) * (xf + 9)

let rec fact n =
   match n with
    | 1 -> 1
    | _ -> n * fact (n-1)

let a = 1
let b = 2
let _ = [a; b]

(* To Be Done *)

(* 2.3.2 Symbolic Data - Example: Symbolic Differentiation *)

(* representing algebraic expressions *)
type term = Number of int
          | Variable of char
          | Sum of term * term
          | Product of term * term

let isNumber = function
   | Number x -> true
   | _ -> false

let isSame_number = function
   | Number x, Number y -> (x = y)
   | _ -> false

let isVariable = function
   | Variable x -> true
   | _ -> false

let isSame_variable = function
   | Variable x, Variable y -> (x = y)
   | _ -> false

let isSum = function
   | Sum (x, y) -> true
   | _ -> false

let isProduct = function
   | Product (x, y) -> true
   | _ -> false

let make_sum = function
   | Number x, Number y -> Number (x + y)
   | x, y -> Sum (x, y)

let make_product = function
   | Number x, Number y -> Number (x * y)
   | x, y -> Product (x, y)

let addend = function
   | Sum (x, y) -> x
   | _ -> failwith "Error"

let augend = function
   | Sum (x, y) -> y
   | _ -> failwith "Error"

let multiplier = function
   | Product (x, y) -> x
   | _ -> failwith "Error"

let multiplicand = function
   | Product (x, y) -> y
   | _ -> failwith "Error"

let rec deriv exp var =
   if isNumber exp
      then Number 0
      else
         if isVariable exp
            then
               if isSame_variable(exp, var)
                  then Number 1
                  else Number 0
            else
               if isSum exp
                  then make_sum(deriv (addend exp) var, deriv (augend exp) var)
                  else
                     if isProduct exp
                        then
                           make_sum(
                              make_product(multiplier exp, deriv (multiplicand exp) var),
                              make_product(deriv (multiplier exp) var, multiplicand exp))
                        else failwith "Error"

(* dx(x + 3) = 1 *)
let d1 = deriv (Sum(Variable 'x', Number 3)) (Variable 'x')

(* dx(x*y) = y *)
let d2 = deriv (Product(Variable 'x', Variable 'y')) (Variable 'x')

(* dx(x*y + x + 3) = y + 1 *)
let d3 = deriv (Sum(Sum(Product(Variable 'x', Variable 'y'), Variable 'x'), Number 3)) (Variable 'x')

(* With simplification *)
let make_sum' = function
   | Number 0, y -> y
   | x, Number 0 -> x
   | Number x, Number y -> Number (x + y)
   | x, y -> Sum (x, y)

let make_product' = function
   | Number 0, y -> Number 0
   | x, Number 0 -> Number 0
   | Number 1, y -> y
   | x, Number 1 -> x
   | Number x, Number y -> Number (x * y)
   | x, y -> Product (x, y)

let deriv' exp var =
   match exp, var with
    | Number x, var -> Number 0
    | Variable x, Variable y when x = y -> Number 1
    | Variable x, Variable y -> Number 0
    | Variable x, _ -> Number 0
    | Sum (x, y), _ -> make_sum'(deriv x var, deriv y var)
    | Product(x, y), var -> make_sum'(make_product'(x, deriv y var), make_product'(deriv x var, y))

(* dx(x + 3) = 1 *)
let d1' = deriv (Sum(Variable 'x', Number 3)) (Variable 'x')

(* dx(x*y) = y *)
let d2' = deriv (Product(Variable 'x', Variable 'y')) (Variable 'x')

(* dx(x*y + x + 3) = y + 1 *)
let d3' = deriv (Sum(Sum(Product(Variable 'x', Variable 'y'), Variable 'x'), Number 3)) (Variable 'x')

(* EXERCISE 2.57 *)
(* dx(x*y*(x+3)) = dx(x*x*y + x*y*3) = 2xy + 3y *)
(* exercise left to reader to define appropriate functions
   let d4 = derivx (Product(Product(Variable 'x', Variable 'y'), Sum(Variable 'x', Number 3))) (Variable 'x') *)

(* 2.3.3 Symbolic Data - Example: Representing Sets *)

(* unordered *)
let rec is_element_of_set x = function
   | [] -> false
   | y::ys when x = y -> true
   | y::ys -> is_element_of_set x ys

let adjoin_set x set =
   if is_element_of_set x set
      then set
      else x::set

let rec intersection_set set1 set2 =
   match set1, set2 with
    | [], _ -> []
    | _, [] -> []
    | x::xs, _ ->
      if is_element_of_set x set2
         then x::intersection_set xs set2
         else intersection_set xs set2

(* ordered *)
let rec is_element_of_set' x = function
   | [] -> false
   | y::ys when x = y -> true
   | y::ys when x < y -> false
   | y::ys -> is_element_of_set' x ys

let rec intersection_set' set1 set2 =
   match set1, set2 with
    | [], _ -> []
    | _, [] -> []
    | x::xs, y::ys when x = y -> x::intersection_set' xs ys
    | x::xs, y::ys when x < y -> intersection_set' xs set2
    | x::xs, y::ys -> intersection_set' set1 ys

(* binary trees *)
type 'a btree = Leaf
              | Node of 'a * 'a btree * 'a btree

let rec is_element_of_set'' x = function
   | Leaf -> false
   | Node(y, left, right) when x = y -> true
   | Node(y, left, right) when x < y -> is_element_of_set'' x left
   | Node(y, left, right) -> is_element_of_set'' x right

let _ = is_element_of_set'' 3 (Node(2, Node(1, Leaf, Leaf), Node(3, Leaf, Leaf)))

let rec adjoin_set' x sety =
   match sety with
    | Leaf -> Node(x, Leaf, Leaf)
    | Node(y, left, right) when x = y -> sety
    | Node(y, left, right) when x < y -> Node(y, adjoin_set' x left, right)
    | Node(y, left, right) -> Node(y, left, adjoin_set' x right)

adjoin_set' 3 (Node(4, Node(2, Leaf, Leaf), Node(6, Leaf, Leaf)))

(* Exercise 2.63 *)
let rec tree_to_list' tree =
   match tree with
    | Leaf -> []
    | Node(y, left, right) ->
      tree_to_list' left @ y::tree_to_list' right
let _ = tree_to_list'(Node(4, Node(2, Leaf, Leaf), Node(6, Leaf, Leaf)))

let tree_to_list'' tree =
   let rec copy_to_list t ys =
      match t with
       | Leaf -> ys
       | Node(x, left, right) -> copy_to_list left (x::copy_to_list right ys)
   in copy_to_list tree []
let _ = tree_to_list''(Node(4, Node(2, Leaf, Leaf), Node(6, Leaf, Leaf)))

(* Exercise 2.64 *)
let rec partial_tree elts n =
   match n with
    | 0 -> (Leaf, elts)
    | _ ->
      let left_size = (n - 1) / 2 in
      let right_size = n - (left_size + 1) in
      let left_result = partial_tree elts left_size in
      let (left_tree, non_left_elts) = left_result in
      let this_entry = List.hd non_left_elts in
      let right_result = partial_tree (List.tl non_left_elts) right_size in
      let (right_tree, remaining_elts)  = right_result
      in (Node(this_entry, left_tree, right_tree), remaining_elts)

let list_to_tree elements =
   let (result, _) = partial_tree elements (length elements)
   in result

let _ = list_to_tree [2; 4; 6]

(* information retrieval *)
type info_rec = { key:int; name:string; age:int }
type information = Information of info_rec
let rec lookup given_key = function
   | [] -> failwith "Error"
   | info::xs ->
      if given_key = info.key
         then info
         else lookup given_key xs

(* 2.3.4 Symbolic Data - Example: Huffman Encoding Trees *)

(* representing *)
type ('a, 'b) leaf_rec = { symbol:'a; weight:'b }
 and ('a, 'b) tree_rec = { left:('a, 'b) btree; right:('a, 'b) btree; symbols:'a list; weights:'b }
 and ('a, 'b) btree = Leaf of ('a, 'b) leaf_rec
                    | Tree of ('a, 'b) tree_rec

let make_leaf symbol weight = Leaf{ symbol=symbol; weight=weight }

let isLeaf = function
   | Leaf _ -> true
   | _ -> false

let symbol_leaf = function
   | Leaf x -> x.symbol
   | _ -> failwith "Error"

let weight_leaf = function
   | Leaf x -> x.weight
   | _ -> failwith "Error"

let symbols = function
   | Leaf x -> [x.symbol]
   | Tree x -> x.symbols

let weight = function
   | Leaf x -> x.weight
   | Tree x -> x.weights

let make_code_tree left right =
   Tree{ left = left;
         right = right;
         symbols = symbols left @ symbols right;
         weights = weight left + weight right }

let left_Node = function
   | Tree x -> x.left
   | _ -> failwith "Error"
let right_Node = function
   | Tree x -> x.right
   | _ -> failwith "Error"

let choose_Node n node =
   match n with
    | 0 -> left_Node node
    | 1 -> right_Node node
    | _ -> failwith "Error"

(* decoding *)
let decode bits tree =
   let rec decode' n1 n2 =
      match n1 with
       | [] -> []
       | x::xs ->
         let next_Node = choose_Node x n2
         in
            if isLeaf next_Node
               then symbol_leaf next_Node::decode' xs tree
               else decode' xs next_Node
   in decode' bits tree

(* sets *)
let rec adjoin_set'' x = function
   | [] -> [x]
   | y::ys ->
      if weight x < weight y
         then x::y::ys
         else y::adjoin_set'' x ys

let rec make_leaf_set = function
   | Leaf x::pairs ->
      adjoin_set (make_leaf x.symbol x.weight) (make_leaf_set pairs)
  | _ -> failwith "Error"

(* Exercise 2.67 *)
let sample_tree =
   make_code_tree
      (make_leaf 'A' 4)
      (make_code_tree
         (make_leaf 'B' 2)
         (make_code_tree
            (make_leaf 'D' 1)
            (make_leaf 'C' 1)))

let sample_message = [0; 1; 1; 0; 0; 1; 0; 1; 0; 1; 1; 1; 0]

let test = implode(decode sample_message sample_tree)

(* Exercise 2.68 *)
(* exercise left to reader to define appropriate functions
   let rec encode message tree =
      match message with
       | [] -> []
       | x::xs -> encode_symbol x tree @ encode xs tree *)

(* 2.4.1 Multiple Representations for Abstract Data - Representations for Complex Numbers *)
let square_float' x = x * x

(* Rectangular *)
let real_part z = List.hd z
let imag_part z = List.hd(List.tl z)

let magnitude z =
   sqrt(square_float (real_part z) + square_float (imag_part z))

let angle z =
   atan2 (imag_part z) (real_part z)

let make_from_float_imag x y = [x; y]
let make_from_mag_ang r a =
   [r * cos a; r * sin a]

module sicp_polar =
(* polar *)
   let magnitude (z : float list) = List.hd z
   let angle (z : float list) = List.hd(List.tl z)

   let real_part z =
      magnitude z * cos(angle z)

   let imag_part z =
      magnitude z * sin(angle z)

   let make_from_float_imag x y =
      [sqrt(square_float x + square_float y); atan2 y x]

   let make_from_mag_ang r a = [r; a]

(* using the abstract type *)
let z' = [1.0; 2.0]
make_from_float_imag (real_part z') (imag_part z')
make_from_mag_ang (magnitude z') (angle z')

let add_complex z1 z2 =
   make_from_float_imag
      (real_part z1 + real_part z2)
      (imag_part z1 + imag_part z2)

let sub_complex z1 z2 =
   make_from_float_imag
      (real_part z1 - real_part z2)
      (imag_part z1 - imag_part z2)

let mul_complex z1 z2 =
   make_from_mag_ang
      (magnitude z1 * magnitude z2)
      (angle z1 + angle z2)

let div_complex z1 z2 =
   make_from_mag_ang
      (magnitude z1 / magnitude z2)
      (angle z1 - angle z2)

(* 2.4.2 Multiple Representations for Abstract Data - Tagged Data *)

module sicp_intersection =
(* Using List with Intersection type *)
   type 'a tag = Rectangular | Polar | Contents of 'a

   let attach_tag type_tag contents = type_tag::contents

   let type_tag = function
    | Rectangular::_ -> Rectangular
    | Polar::_ -> Polar
    | _ -> failwith "Error"

   let contents = function
    | _::Contents x::[] -> x
    | _ -> failwith "Error"

   let isRectangular = function
    | Rectangular::_ -> true
    | _ -> false

   let isPolar = function
    | Polar::_ -> true
    | _ -> false

   (* Rectangular *)
   let make_from_float_imag_rectangular x y =
      [Rectangular; Contents x; Contents y]
   let make_from_mag_ang_rectangular r a =
      [Rectangular; Contents (r * cos a); Contents (r * sin a)]

   let real_part_rectangular = function
    | Rectangular::Contents x::_ -> x
    | _ -> failwith "Error"
   let imag_part_rectangular = function
    | Rectangular::_::Contents y::_ -> y
    | _ -> failwith "Error"

   let magnitude_rectangular z =
      sqrt(square_float (real_part_rectangular z) + square_float (imag_part_rectangular z))
   let angle_rectangular z =
      atan2 (imag_part_rectangular z) (real_part_rectangular z)

   (* Polar *)
   let make_from_float_imag_polar x y =
      [Polar; Contents (sqrt(square_float x + square_float y)); Contents (atan2 y x)]
   let make_from_mag_ang_polar r a =
      [Polar; Contents r; Contents a]

   let magnitude_polar = function
    | Polar::Contents x::_ -> x : float
    | _ -> failwith "Error"
   let angle_polar = function
    | Polar::_::Contents y::_ -> y : float
    | _ -> failwith "Error"

   let real_part_polar z =
      magnitude_polar z * cos(angle_polar z)
   let imag_part_polar z =
      magnitude_polar z * sin(angle_polar z)

   (* Generic selectors *)
   let real_part z =
      match z with
       | Rectangular::_ -> real_part_rectangular z
       | Polar::_ -> real_part_polar z
       | _ -> failwith "Error"
   let imag_part z =
      match z with
       | Rectangular::_ -> imag_part_rectangular z
       | Polar::_ -> imag_part_polar z
       | _ -> failwith "Error"

   let magnitude z =
      match z with
       | Rectangular::_ -> magnitude_rectangular z
       | Polar::_ -> magnitude_polar z
       | _ -> failwith "Error"
   let angle z =
      match z with
       | Rectangular::_ -> angle_rectangular z
       | Polar::_ -> angle_polar z
       | _ -> failwith "Error"

   (* same as before *)
   let add_complex z1 z2 =
      make_from_float_imag
         (real_part z1 + real_part z2)
         (imag_part z1 + imag_part z2)
   let sub_complex z1 z2 =
      make_from_float_imag
         (real_part z1 - real_part z2)
         (imag_part z1 - imag_part z2)
   let mul_complex z1 z2 =
      make_from_mag_ang
         (magnitude z1 * magnitude z2)
         (angle z1 + angle z2)
   let div_complex z1 z2 =
      make_from_mag_ang
         (magnitude z1 / magnitude z2)
         (angle z1 - angle z2)

   (* Constructors for complex numbers *)
   let make_from_float_imag x y =
      make_from_float_imag_rectangular x y
   let make_from_mag_ang r a =
      make_from_mag_ang_polar r a
(* End Using List with Intersection type *)

module sicp_records =
(* Using Records *)
   type 'a rectangular = { real_part : 'a; imag_part : 'a }
   type 'a polar = { magnitude : 'a; angle : 'a }
   type 'a tag = Rectangular of 'a rectangular
               | Polar of 'a polar

   let isRectangular' = function
     | Rectangular _ -> true
     | _ -> false

   let isPolar' = function
    | Polar _ -> true
    | _ -> false

   (* Rectangular *)
   let make_from_float_imag_rectangular x y =
      Rectangular{ real_part = x; imag_part = y }
   let make_from_mag_ang_rectangular r a =
      Rectangular{ real_part = r * cos a; imag_part = r * sin a }

   let real_part_rectangular = function
    | Rectangular x -> x.real_part
    | _ -> failwith "Error"
   let imag_part_rectangular = function
    | Rectangular y -> y.imag_part
    | _ -> failwith "Error"

   let magnitude_rectangular z =
      sqrt(square_float(real_part_rectangular z) + square_float(imag_part_rectangular z))
   let angle_rectangular z =
      atan2 (imag_part_rectangular z) (real_part_rectangular z)

   (* Polar *)
   let make_from_float_imag_polar x y =
      Polar { magnitude = sqrt(square_float x + square_float y); angle = atan2 y x }
   let make_from_mag_ang_polar r a =
      Polar { magnitude = r; angle = a }

   let magnitude_polar = function
     | Polar x -> x.magnitude : float
     | _ -> failwith "Error"
   let angle_polar = function
     | Polar y -> y.angle
     | _ -> failwith "Error"

   let real_part_polar z =
      magnitude_polar z * cos(angle_polar z)
   let imag_part_polar z =
      magnitude_polar z * sin(angle_polar z)

   (* Generic selectors *)
   let real_part z =
      match z with
       | Rectangular _ -> real_part_rectangular z
       | Polar _ -> real_part_polar z
   let imag_part z =
      match z with
       | Rectangular _ -> imag_part_rectangular z
       | Polar _ -> imag_part_polar z

   let magnitude z =
      match z with
       | Rectangular _ -> magnitude_rectangular z
       | Polar _ -> magnitude_polar z
   let angle z =
      match z with
       | Rectangular _ -> angle_rectangular z
       | Polar _ -> angle_polar z

   (* same as before *)
   let add_complex z1 z2 =
      make_from_float_imag
         (real_part z1 + real_part z2)
         (imag_part z1 + imag_part z2)
   let sub_complex z1 z2 =
      make_from_float_imag
         (real_part z1 - real_part z2)
         (imag_part z1 - imag_part z2)
   let mul_complex z1 z2 =
      make_from_mag_ang
         (magnitude z1 * magnitude z2)
         (angle z1 + angle z2)
   let div_complex z1 z2 =
      make_from_mag_ang
         (magnitude z1 / magnitude z2)
         (angle z1 - angle z2)

   (* Constructors for complex numbers *)
   let make_from_float_imag x y =
      make_from_float_imag_rectangular x y
   let make_from_mag_ang r a =
      make_from_mag_ang_polar r a
(* End Using Records *)

(* 2.4.3 Multiple Representations for Abstract Data - Data-Directed Programming and Additivity *)

(* To Be Done *)

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