(* Q1 *)

type succ = z | s of succ;;

exception Underflow;;
exception DivbyZero;;

let rec add(x,y) = match x with z -> y | s(w) -> s(add(w,y));;
let rec subtract(x,y) = match (x,y) with 
   (x,z) -> x
 | (z,_) -> raise (Underflow)
 | (s(u),s(v)) -> subtract(u,v);;
let rec multiply(x,y) = match y with
   z -> z
 | s(z) -> x
 | s(w) -> add(x,multiply(x,w));;
let rec divide(x,y) = match y with
   z -> raise DivbyZero
 | s(z) -> (x,z)
 | y -> try let (d,m) = divide(subtract(x,y),y) in (s(d),m)
        with Underflow -> (z,x);;

(* Q2 *)

let length l = 
  let rec len_aux n = function [] -> n
                             | _::xs -> len_aux (n+1) xs
  in len_aux 0 l;; 

let reverse =
  let rec rev = function ([],accum) -> accum
                       | (x::xs,accum) -> rev(xs,x::accum)
  in (function l -> rev(l,[]));;

let wf_poly(poly(degree,factors) as p) =
  let zero_leading_term = function 0.0::_ -> true
                                 | _ -> false
  in if (degree < 0)
     then raise (DegreeLessthanZero p)
  else if (length(factors) <> degree+1)
     then raise (WrongNumFactors p)
  else if (zero_leading_term(factors) && degree > 0)
     then raise (ZeroLeadingTerm p)
  else (degree,factors);;

let deriv(p) = 
 let (degree,factors) = wf_poly(p)
 in let rec deriv_factors = 
        function (1,linear::const::[]) -> linear::[]
               | (n,leading::rest) -> (float_of_int(n) *. leading)
                                      ::deriv_factors(n-1,rest)
    in match degree with
       0 -> poly(0,[0.0])
     | n -> poly(n-1,deriv_factors(n,factors));;

let defintegral(p) =
 let (degree,factors) = wf_poly(p)
 in let rec integrate_factors =
        function (1,const::[]) -> [const;0.0]
               | (nplus1,leading::rest) -> (leading /. float_of_int(nplus1))
                                           ::integrate_factors(nplus1-1,rest)
    in poly(degree+1,integrate_factors(degree+1,factors));;

let reify(p) =
  let factors = snd(wf_poly(p))
  in let rec reify_factors = 
         function ([],faccum) -> faccum
                | (f::fs,faccum) -> reify_factors(fs,
                                     (function x -> faccum(x) *. x +. f))
     in reify_factors(factors,(function x -> 0.0));;

let add_poly(p1,p2) =
  let (degree1,factors1) = wf_poly(p1)
  and (degree2,factors2) = wf_poly(p2)
  and map_pair(f) = 
       let rec mp = (function ([],l2) -> l2
                            | (l1,[]) -> l1
                            | (x::xs,y::ys) -> f(x,y)::mp(xs,ys))
       in mp
  in poly(max(degree1)(degree2),
          reverse(map_pair(function (x,y) -> x+.y)
                          (reverse(factors1),reverse(factors2))));;
(* Q3 *)

type colour = black | white | unknown;;
type reply = c of colour | ok of unit;;
type message = status | link of (message -> reply) | paint of colour;;
type edge = e of int * int;;
type adjGraph == edge list;;
type lambdaGraph == (message -> reply) list;;

exception NonPosInt of int;;
exception NotTwoColourable;;

let oddcycle = [e(1,2);e(2,3);e(3,1)];;
let tree = [e(1,5);e(2,5);e(3,6);e(4,6);e(5,7);e(6,7)];;

let unit_of_ok = function ok(()) -> ();;
let opposite = function white -> black
                      | black -> white
                      | unknown -> unknown;;
let compose(f)(g) = (function x -> f(g(x)));;

exception ListLengthExceeded of int;;
exception NotListIndex of int;;
let rec nth = function n when n > 0 -> (function [] -> raise (ListLengthExceeded n)
                                               | x::xs -> if (n=1) then x else nth (n-1) xs)
                     | m -> raise (NotListIndex m);;

exception EmptyList;;
let max_list l = 
  let rec max_list_aux accum = (function [] -> accum
                                       | x::xs -> max_list_aux(max(accum)(x))(xs))
  in (function [] -> raise EmptyList
             | x::xs -> max_list_aux x xs)(l);;

let rec init_lambdaG = 
  function 0 -> []
         | n -> (let neighbours = ref []
                 and colour = ref unknown
                 in let broadcast = 
                         (function clr -> do_list(compose(unit_of_ok)
                                                         (function node -> node(paint(clr))))
                                                 (!neighbours))
                 in (function status -> c(!colour)
                            | link(lambda) -> 
                                  let tail = !neighbours
                                  in ok(neighbours := lambda::tail)
                            | paint(clr) -> if (!colour=clr) then ok(())
                                            else if (!colour=unknown) 
                                                 then ok(colour := clr;
                                                         broadcast(opposite(clr)))
                                            else raise NotTwoColourable)
                    ::init_lambdaG(n-1));;

let link_edges(adjGraph,lambdaG) =
  ( do_list(compose(unit_of_ok)(function e(n1,n2) -> nth(n1)(lambdaG)(link(nth(n2)(lambdaG)))))
           (adjGraph);
    do_list(compose(unit_of_ok)(function e(n1,n2) -> nth(n2)(lambdaG)(link(nth(n1)(lambdaG)))))
           (adjGraph)
  );;

let lambdaG_of_adjG adjGraph = 
  let negtest = (function n when n < 1 -> raise (NonPosInt n)
                        | n -> n)
  in let lambdaG = init_lambdaG(max_list(map(function e(n1,n2) 
                                             -> max(negtest(n1))(negtest(n2)))
                                            (adjGraph)))
  in (link_edges(adjGraph,lambdaG);
      lambdaG);;

let two_colour adjGraph = 
  let prime_painting lG = do_list(compose(unit_of_ok)
                                         (function node -> match node(status) with
                                                             c(unknown) -> node(paint(white))
                                                           | _ -> ok(())))
                                 (lG)
  and lambdaG = lambdaG_of_adjG(adjGraph)
  in ( prime_painting(lambdaG);
       map(compose(function c(colour) -> colour)(function node -> node(status)))
          (lambdaG));;