(* =============== Esercizi del cap. 3.7 =================== *)
 
(* ------------- 1  ------------- *) 
type number = 
    Int of int
  | Float of float;;

(* diff : number * number -> number *)
(* sottrazione *)
let diff = function
    (Int x, Int y) -> Int (x - y)
  | (Float x, Float y) -> Float(x-.y)
  | (Float x, Int y) -> Float(x-.float(y))
  | (Int x, Float y) -> Float(float(x)-.y)

(* prod : number * number -> number *)
(* prodotto *)
let prod = function
    (Int x, Int y) -> Int (x * y)
  | (Float x, Float y) -> Float(x *. y)
  | (Float x, Int y) -> Float(x *. float(y))
  | (Int x, Float y) -> Float(float(x) *. y);;

(*  div : number * number -> number *)
(* divisione *)
let div = function
    (Int x, Int y) -> 
      if x mod y = 0 then Int(x/y)
      else Float(float(x)/.float(y))
  | (Float x, Float y) -> 
      if x/.y -. float(truncate(x/.y)) = 0.0
      then Int(truncate(x/.y))
      else Float(x/.y)
  | (Float x, Int y) -> 
      if x/.float(y) -. float(truncate(x/.float(y))) = 0.0
      then Int(truncate(x/.float(y)))
      else Float(x/.float(y))
  | (Int x, Float y) -> 
      if float(x)/.y -. float(truncate(float(x)/.y)) = 0.0
      then Int(truncate(float(x)/.y))
      else Float(float(x)/.y);;

(* ------------------ 2 ----------------- *)
type nat = 
    Zero 
  | Succ of nat;;
type natlist = 
    Nil 
  | Cons of nat * natlist;;
exception  EmptyNatList;;

(* head: natlist -> nat *)
let head = function
    Nil -> raise EmptyNatList
  | Cons(n,_) -> n;;

(* ------------------ 3 ----------------- *)
(* rest: natlist -> natlist *)
let rest = function
    Nil -> raise EmptyNatList
  | Cons(_,nl) -> nl;;

(* ------------- 4  ------------- *) 

type expr = 
    Int of int
  | Var of string
  | Sum of expr * expr
  | Mult of expr * expr;;

(* (a) is_var_in : string list -> expr -> bool *)
let rec is_var_in lst e = 
  match e with
    Var st -> List.mem st lst
  | Int n  -> true
  | Sum (e1,e2)  -> is_var_in lst e1 && is_var_in lst e2
  | Mult (e1,e2)  -> is_var_in lst e1 && is_var_in lst e2;;

(* per il punto (b), definiamo prima l'unione insiemistica *)
(* setadd : 'a -> 'a list -> 'a list *)
let setadd x xs = 
  if List.mem x xs then xs else (x::xs);;

(* union : 'a list -> 'a list -> 'a list *)
let rec union xs = function
    [] -> xs
  | y::ys -> setadd y (union xs ys);;

(* list_of_vars: expr -> string list *)
let rec list_of_vars = function    
    Var st -> [st]
  | Int n  -> []
  | Sum (e1,e2)  -> union (list_of_vars e1) (list_of_vars e2) 
  | Mult (e1,e2)  -> union (list_of_vars e1) (list_of_vars e2);;

(* ------------- 5  ------------- *) 
type 'a tree =  
    Empty
  | Tr of 'a * 'a tree * 'a tree;;

(* leaves : 'a tree -> int *)
let rec leaves = function
    Empty -> 1
  | Tr(_,t1,t2) -> leaves t1 + leaves t2;;

(* ------------- 6  ------------- *) 
exception EmptyTree;;

(* from_bool_list: bool list * 'a tree -> 'a *)
let rec from_bool_list = function
    (_,Empty) -> raise EmptyTree 
  | ([],Tr(x,_,_)) -> x
  | (x::xs,Tr(_,t1,t2)) -> 
      if x then from_bool_list(xs,t1)
      else from_bool_list(xs,t2);;

(* ------------- 7  ------------- *) 
(* versione 1: ricorsione primaria sulla lista e secondariamente
   sull'albero *)
(* occurs : 'a -> 'a tree -> bool *)
(* occurs x t determina se x occorre nell'albero t *)
let rec occurs x = function
  Empty -> false
| Tr(y,t1,t2) -> x=y or occurs x t1 or occurs x t2;;

(* check : 'a tree -> 'a list -> ('a * bool) list *)
let rec check t = function 
  [] -> []
| x::xs -> (x,occurs x t)::check t xs;;

(* versione 2: ricorsione primaria sull'albero, 
   secondariamente sulla lista *)

(* set : 'a -> ('a * bool) list -> ('a * bool) list *)
(* set x lst: se in lst e' presente la coppia (x,false), la 
   sostituisce con (x,true) *)
let rec set x = function
    [] -> []
  | (y,b)::rest -> 
      if x=y then (y,true)::rest
      else (y,b)::set x rest;;

(* initialize : 'a list -> ('a * bool) list *)
(* da una lista di elementi [x1,...,xn] crea la lista di coppie
   [(x1,false),...,(xn,false)] *)
let rec initialize = function
    [] -> []
  | x::xs -> (x,false)::initialize xs;;

(* oppure *)
let initialize lst = 
  List.map (function x -> (x,false)) lst;;

(* check : 'a tree -> 'a list -> ('a * bool) list *)
let rec check t lst = 
  let rec aux result = function
      Empty -> result
    | Tr(x,t1,t2) -> aux (aux (set x result) t2) t1
  in aux (initialize lst) t;;

(* ------------- 8  ------------- *) 
exception EmptyTree;;

(* costo : int tree -> int * int *)
let rec costo = function
    Empty -> raise EmptyTree
  | Tr(x,Empty,Empty) -> (x,x)
  | Tr(x,Empty,t2) -> 
      let (y,c) = costo t2
      in (y,c+x)
  | Tr(x,t1,Empty) -> 
      let (y,c) = costo t1
      in (y,c+x)
  | Tr(x,t1,t2) -> 
      let (y1,c1) = costo t1
      and (y2,c2) = costo t2
      in if c1>c2 then (y1,c1+x)
      else (y2,c2+x);;

(* ------------- 10  ------------- *) 
(* print_int_list: int list -> unit *)
let print_int_list l = 
    let rec aux = function
	[] -> print_string("]")
      |	[x] -> print_string((string_of_int x)^"]")
      | x::xs -> (print_string(string_of_int x ^"; ");
		  aux xs)
    in print_string("["); aux(l); print_newline();;

(* oppure: *)
let print_int_list l = 
  print_string "[";
  print_string (String.concat ";" 
		  (List.map string_of_int l));
  print_string "]\n";;

(* print_string_list : string list -> unit *)
let print_string_list l = 
  print_string "[";
  print_string (String.concat ";" l);
  print_string "]\n";;

(* oppure *)
let print_string_list l = 
    let rec aux = function
	[] -> print_string("]")
      |	[x] -> print_string(x ^ "]")
      | x::xs -> (print_string(x ^"; ");
		  aux xs)
    in print_string("["); aux(l); print_newline();;

(* pair2string : int * string -> string *)
let pair2string (x,s) = "("^(string_of_int x)^","^s^")";;

(* print_pair_list : (int * string) list -> unit *)
let print_pair_list l =
  print_string "[";
  print_string (String.concat ";" 
		  (List.map pair2string l));
  print_string "]\n";;

(* oppure *)
let rec print_pair_list l =
    let rec aux = function
	[] -> print_string("]")
      |	[x] -> print_string(pair2string x)
      | x::xs -> (print_string(pair2string x);
		  aux xs)
    in (print_string("["); aux(l); print_newline());;

(* ------------- 11  ------------- *) 
type expr = 
    Int of int
  | Var of string
  | Sum of expr * expr
  | Mult of expr * expr
  | Jolly;;

(* expr_match : expr * expr -> bool *)
let rec expr_match = function 
    (_,Jolly)  -> true
  | (Sum(e1,e2),Sum(e3,e4)) -> 
      expr_match(e1,e3) && expr_match(e2,e4)
  | (Mult(e1,e2),Mult(e3,e4)) -> 
      expr_match(e1,e3) && expr_match(e2,e4)
  | (e1,e2) -> e1 = e2;;

(* ------------- 12  ------------- *) 
(* leaf : 'a -> 'a tree *)
let leaf x = Tr(x,Empty,Empty);;

(* maxmatch : string tree * string tree -> string tree *)
let rec maxmatch = function
    (Empty,Empty) -> Empty
  | (Tr(x,t1,t2),Tr(y,u1,u2)) ->
      if x=y then Tr(x,maxmatch(t1,u1),maxmatch(t2,u2))
      else leaf "@"
  | _  -> leaf "@";;

(* lo stesso esercizio si puo' svolgere con il tipo di dati expr
   con il Jolly invece della stringa "@" *)

(* maxmatch : expr * expr -> expr *)
let rec maxmatch = function
    (Sum(t1,t2),Sum(u1,u2)) ->
      Sum(maxmatch(t1,u1),maxmatch(t2,u2))
  | (Mult(t1,t2),Mult(u1,u2)) ->
      Mult(maxmatch(t1,u1),maxmatch(t2,u2))
  | (e1,e2) -> if e1=e2 then e1 else Jolly;;

(* ----------------- 13 ----------------- *)
type token = 
    Tint of int
  | Tvar of string
  | Op of string

type expr = 
    Int of int
  | Var of string
  | Sum of expr * expr
  | Mult of expr * expr
  | Diff of expr * expr
  | Div of expr * expr

exception SyntaxError

(* convert : token list -> expr *)
let convert e = 
  (* aux : token list -> expr * token list *)
  let rec aux = function
    (Tint n)::rest -> (Int n,rest)
  | (Tvar x)::rest -> (Var x,rest)
  | Op op::rest ->
      let (t1,rest1) = aux rest in
      let (t2,rest2) = aux rest1 in
      ((match op with
	"+" -> Sum(t1,t2)
      | "*" -> Mult(t1,t2)
      | "-" -> Diff(t1,t2)
      | "/" -> Div(t1,t2)
      | _ -> raise SyntaxError), 
       rest2)
  | _ -> raise SyntaxError
  in let (t,rest) = aux e
  in if rest=[] then t
  else raise SyntaxError

(* ---------------- 15 ---------------- *)
	  
(* alberi n-ari *)
type 'a ntree = Tr of 'a * 'a ntree list;;
let nleaf x = Tr(x,[])
let albero =
  Tr("Aldo",
       [Tr("Barbara",[nleaf "Carlo";
		      nleaf "Claudia"; 
		      nleaf "Carmelo"]);
	Tr("Biagio",[nleaf "Dario";
		     nleaf "Daniela"]);
	Tr("Bernardo",[nleaf "Flavio";
		       nleaf "Francesca";
		       nleaf "Fulvio"])]);;

(*  postorder : 'a ntree -> 'a list
    post_lst : 'a ntree list -> 'a list *)
let rec postorder (Tr(x,tlist)) =
  (post_lst tlist) @ [x]
and post_lst = function
    [] -> []
  | t::ts -> (postorder t) @ (post_lst ts)
 
(* inorder : 'a ntree -> 'a list 
   inord_lst : 'a ntree list -> 'a list *)
let rec inorder = function
    Tr(x,[]) -> [x]
  | Tr(x,t::ts) -> (inorder t)@(x::(inord_lst ts))
and inord_lst = function
    [] -> []
  | t::ts -> (inorder t) @ (inord_lst ts)
 
(* ------------- 16 ---------------- *)
(* leaves : 'a ntree -> 'a list *)
let rec leaves = function
    Tr(x,[]) -> [x]
  | Tr(_,tlist) ->
      List.flatten(List.map leaves tlist)

(* ------------- 17 ---------------- *)
exception Error
(* subtree : int list * 'a ntree -> 'a *)
let rec cerca = function
    ([],Tr(x,_)) -> x 
  | (x::rest,Tr(_,tlist)) ->
      try cerca (rest,List.nth tlist x)
      with Failure "nth" -> raise Error

(* ------------- 18 ---------------- *)
(* ricorsione primaria sulla lista, secondariamente
   sull'albero *)
(* occurs_in : 'a ntree -> 'a -> bool
      occurs_in t y determina se y occorre in t
   occurs_in_tlist : 'a ntree list -> 'a -> bool
      occurs_in_tlist [t1,...,tn] y determina se y occorre in uno
      degli alberi t1,...,tn                                   *)
let rec occurs_in (Tr(x,tlist)) y = 
    x=y or occurs_in_tlist tlist y
and occurs_in_tlist tlist y = match tlist with
  [] -> false
| t::ts -> occurs_in t y or occurs_in_tlist ts y;;

(*  mkpairs : 'a ntree -> 'a list -> ('a * bool) list *)
let rec mkpairs t = function
    [] -> []
  | x::rest -> 
      (x,occurs_in t x)::mkpairs t rest

(* ------------- 19 ------------------ *)
(* maxpair : ('a * 'b) list -> 'a * 'b *)
(* maxpair lst = coppia (x,y) in lst con massimo y *)
let rec maxpair = function
    [] -> raise Error
  | [p] -> p
  | ((x,c)::(y,c')::rest) ->
      if c>c' then maxpair ((x,c)::rest)
      else maxpair ((y,c')::rest)

(* costo : int ntree -> int * int *)
let rec costo = function
    Tr(x,[]) -> (x,x)
  | Tr(x,tlist) ->
      let (y,c) = maxpair (List.map costo tlist)
      in (y,x+c)

(* ------------- 20 ----------------- *)

type term = Var of string
  | Const of string
  | Appl of string * term list

let t=Appl("*",[Const "1";Var "x";
		Appl("+",[Var "y";Const "3"])]);;
(* a *)
(* mkset: 'a list -> 'a list *)
let rec mkset = function
    [] -> []
  | x::rest -> setadd x (mkset rest)

(* vars : term -> string list *)
let rec vars = function
    Var x -> [x]
  | Const x -> []
  | Appl(op,tlist) ->
      mkset(List.flatten (List.map vars tlist))

(* b *)
(* subterm: term -> term -> bool *)
let rec subterm t t' = 
  t=t' or 
  match t' with
  Appl(_,tlist) ->
    List.exists (subterm t) tlist
  | _ -> false

(* c *)
exception Undefined
(*  subst : (string -> term) -> term -> term *)
let rec subst s = function
    Var x -> 
      (try s x 
      with Undefined -> Var x)
  | Appl(op,tlist) ->
      Appl(op,List.map (subst s) tlist)
  | t -> t

(* ----------------- 21 ----------------- *)
type 'a graph = Gr of ('a * 'a) list;;

let grafo1 = Gr [(1,2);(1,3);(1,4);(2,6);
                 (3,5);(4,6);(6,5);(6,7);(5,4)];;

(* ----- a ----- *)
(* preds : 'a graph -> 'a -> 'a list *)
let preds (Gr arcs) a =
  let rec aux = function
      [] -> []
    | (x,y)::xs -> 
	if y=a then x::aux xs
        else aux  xs
  in aux arcs;;
(* OPPURE: *)
let preds (Gr arcs) a = 
  List.map fst 
    (List.filter (function (_,y) -> a=y) arcs);;

(* ----- b ----- *)
(* in_deg : 'a graph -> 'a -> int *)
let in_deg g a = List.length (preds g a);;

(* ----- c  ----- *)
(* succ : 'a graph -> 'a -> 'a list *)
let succ (Gr arcs) a =
    let  rec aux = function
        [] -> []
      | (x,y)::rest ->
          if a = x then y::(aux rest)
          else aux rest
    in aux arcs;;
(*  out_deg : 'a graph -> 'a -> int *)
let out_deg g a =  List.length (succ g a);;

(* ----- d ----- *)
(*  sorgente : 'a graph -> 'a -> bool *)
let  sorgente g a = 
  (in_deg g a) = 0;;

(* ----- e ----- *)
(* funzioni ausiliarie *)
(* setadd : 'a -> 'a list -> 'a list *)
let setadd x xs = 
  if List.mem x xs then xs else x::xs;;

(* nodes : 'a graph -> 'a list *)
let  nodes (Gr arcs) = 
  let rec aux = function
      [] -> []
    | (x,y)::rest -> setadd x (setadd y (aux rest))
  in  aux arcs;;

(* in_grado : 'a graph -> int *)
let  in_grado g =
  let rec aux = function 
      [] -> 0
    | x::xs -> max x (aux xs)
  in aux (List.map (in_deg g) (nodes g));;

(* oppure, senza creare la lista dei gradi dei nodi *)
let in_grado g = 
  let rec aux res = function
      [] -> res
    | x::xs -> aux (max (in_deg g x) res) xs
  in aux 0 (nodes g);;

(* o ancora: *)
let in_grado g = 
  let f acc x = max (in_deg g x) acc
  in List.fold_left f 0 (nodes g);;

(* ----- f ----- *)
(* out_grafo : 'a graph -> int *)
let out_grado g = 
  let rec aux = function
      [] -> 0
    | x::xs -> max x (aux xs) 
  in aux (List.map (out_deg g) (nodes g));;

(* oppure, senza creare la lista dei gradi dei nodi *)
let out_grado g = 
  let rec aux res = function
      [] -> res
    | x::xs -> aux (max (out_deg g x) res) xs
  in aux 0 (nodes g);;

(* o ancora: *)
let out_grado g = 
  let f acc x = max (out_deg g x) acc
  in List.fold_left f 0 (nodes g);;

(* ----- g ----- *)
(* esiste_ciclo *)
(* e' una modifica della depth_first_collect *)
(* ex_cycle : 'a graph -> 'a -> bool *)
let ex_cycle graph start =
    let rec search visited = function
        [] -> false
      | a::rest ->
          if List.mem a visited 
          then a = start or search visited rest
          else search (a::visited) ((succ graph a) @ rest)
    in search [] [start];;

(* OPPURE: la ricerca parte dai successori di start,
   start non e' incluso tra i nodi visitati *)
(* ex_cycle : 'a graph -> 'a -> bool *)
let ex_cycle g start =
  let rec aux visited = function 
      [] -> false
    | x::rest ->
        if List.mem x visited 
        then aux visited rest
        else x=start or aux (x::visited) ((succ g x)@rest)
  in aux [] (succ g start);;

(* ----- h ----- *)
(* non : ('a -> bool) -> 'a -> bool *)
let non p x = not(p x);;

(* ciclico : 'a graph -> bool *)
let ciclico g = 
  List.exists (ex_cycle g) (nodes g);;

let aciclico = non ciclico;;
(* oppure *)
let aciclico g = 
  not (List.exists (ex_cycle g) (nodes g));;

(* ------------- 29 ----------------- *)

(* nodes : 'a graph -> 'a list *)
(* lista dei nodi di un grafo *)
let  nodes (Gr arcs) = 
  let rec aux = function
      [] -> []
    | (x,y)::rest -> setadd x (setadd y (aux rest))
  in  aux arcs;;

exception NotFound
(* initialize: int -> 'a list list *)
(* initialize n = lista con n [] *)
let rec initialize n =
  if n<0 then raise NotFound
  else if n=0 then []
  else []::(initialize (n-1))

(* colora : int -> 'a graph -> 'a list list *)
let colora n (Gr arcs) =
  (* aux: 'a list list -> 'a list list -> 'a list -> 'a list list *)
  (* aux failed sol nodi: *)
  (* failed: partizioni a cui non si puo' aggiungere
             l'eventuale primo nodo di nodi
     sol: partizioni ancora da esaminare per l'eventuale primo nodo
          di nodi
     nodi: lista di nodi in attesa di essere collocati *)
  (* riporta una soluzione, se esiste *)
  let rec aux failed sol = function
      [] -> sol
    | n::ns -> 
	(match sol with
	  [] -> raise NotFound
	| p::rest ->
	    if not (List.exists
		      (function x -> 
			List.mem (n,x) arcs
			  or List.mem (x,n) arcs) p)
              (* non esiste alcun elemento di p collegato a n *)
	    then (try aux [] (failed @ ((n::p)::rest)) ns
	          with NotFound ->
		    aux (p::failed) rest (n::ns))
	    else aux (p::failed) rest (n::ns))
  in aux [] (initialize n) (nodes (Gr arcs))