(******************************************************************************)
(* 1. Un peu d'exercice *******************************************************)
(******************************************************************************)

(* Question 1. *)

let rec mapc f l k = match l with
  | [] -> k []
  | x::q -> mapc f q (fun l -> k ((f x)::l));;

mapc (fun x -> 2*x) [1;6;6;4] (List.iter (fun x -> print_int x; print_newline ()));;

(* Question 2. *)

let rec appendc l1 l2 k = match l1 with
  | [] -> k l2
  | x::q -> appendc q l2 (fun l -> k (x::l));;

appendc [1;6;6;4] [51;42] (List.iter (fun x -> print_int x; print_newline ()));;


(* Question 3. *)

let rec mapc f l k = match l with
  | [] -> k []
  | x::q -> f x (fun y -> mapc f q (fun l -> k (y::l)));;

mapc (fun x k -> k (2*x)) [1;6;6;4] (List.iter (fun x -> print_int x; print_newline ()));;



(******************************************************************************)
(* 2. Arbres de calcul ********************************************************)
(******************************************************************************)

(* 2.2. Préliminaires *********************************************************)

(* Question 1. *)

type tree =
  | TInt of int
  | TAdd of tree * tree
  | TMul of tree * tree;;

let t = TAdd (TMul (TInt 32, TInt 51), TInt 32);;

let rec eval t k = match t with
  | TInt n -> k n
  | TAdd (t1,t2) -> eval t1 (fun n1 -> eval t2 (fun n2 -> k (n1+n2)))
  | TMul (t1,t2) -> eval t1 (fun n1 -> eval t2 (fun n2 -> k (n1*n2)));;

eval t print_int;;


(* 2.3. Préliminaires *********************************************************)

(* Question 2. *)

type symbol = string;;
type tree =
  | TInt of int
  | TAdd of tree * tree
  | TMul of tree * tree
  | TVar of symbol
  | TFun of symbol * tree
  | TApp of tree * tree;;
type value = VInt of int | VFun of symbol * tree;;
type context = (symbol * value) list;;

let rec eval t c k = match t with
  | TInt n -> k (VInt n)
  | TAdd (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1+n2)
								   | _ -> failwith "Malformed expression.")))
  | TMul (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1*n2)
								   | _ -> failwith "Malformed expression.")))
  | TVar s -> k (snd (List.find (fun (s',_) -> s = s') c))
  | TFun (s,t) -> k (VFun (s,t))
  | TApp (t1,t2) -> eval t1 c (fun v1 ->
				 match v1 with 
				   | VFun  (s,t') -> eval t2 c (fun v2 -> eval t' ((s,v2)::c) k)
				   | _ -> failwith "Malformed expression.");;

let print v = match v with
  | VInt n -> print_int n
  | VFun _ -> print_string "<fun>";;

let context = [ ("x", VInt 52) ; ("y", VInt 32) ];;

eval (TApp (TFun ("x", TMul (TVar "x", TInt 32)), TInt 52)) [] print;;
eval (TMul (TVar "x", TInt 32)) context print;;
eval (TFun ("x", TMul (TVar "x", TInt 32))) context print;;


(* 2.4. Exceptions : simulation ***********************************************)

(* Question 3. *)

type symbol = string;;
type tree =
  | TInt of int
  | TAdd of tree * tree
  | TMul of tree * tree
  | TVar of symbol
  | TFun of symbol * tree
  | TApp of tree * tree;;
type 'a value =
  | VInt of int
  | VFun of (symbol * tree)
  | VCont of 'a continuation
and 'a continuation = 'a value -> 'a;;
type 'a context = (symbol * 'a value) list;;

let rec eval t c k = match t with
  | TInt n -> k (VInt n)
  | TAdd (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1+n2)
								   | _ -> failwith "Malformed expression.")))
  | TMul (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1*n2)
								   | _ -> failwith "Malformed expression.")))
  | TVar s -> k (snd (List.find (fun (s',_) -> s = s') c))
  | TFun (s,t) -> k (VFun (s,t))
  | TApp (t1,t2) -> eval t1 c (fun v1 ->
				 match v1 with 
				   | VFun (s,t') -> eval t2 c (fun v2 -> eval t' ((s,v2)::c) k)
				   | VCont k' -> eval t2 c k'
				   | _ -> failwith "Malformed expression.");;

let print v = match v with
  | VInt n  -> print_int n
  | VFun _  -> print_string "<fun>"
  | VCont _ -> print_string "<cont>";;

let expr    = TAdd (TInt 3, TMul (TApp (TVar "raise", TInt 19), TInt 9))
and context = [ ("raise", VCont (fun _ -> print_int 1664)) ;
		("x", VInt 51) ]
in eval expr context print;;


(* Question 4. *)

type symbol = string;;
type tree =
  | TInt of int
  | TAdd of tree * tree
  | TMul of tree * tree
  | TVar of symbol
  | TFun of symbol * tree
  | TApp of tree * tree
  | TTryWith of tree * symbol * tree
  | TRaise of tree;;
type 'a value =
  | VInt of int
  | VFun of (symbol * tree)
  | VCont of 'a continuation
and 'a continuation = 'a value -> 'a;;
type 'a context = (symbol * 'a value) list;;

let rec eval t c k = match t with
  | TInt n -> k (VInt n)
  | TAdd (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1+n2)
								   | _ -> failwith "Malformed expression.")))
  | TMul (t1,t2) -> eval t1 c (fun v1 -> eval t2 c (fun v2 -> k (match v1,v2 with
								   | VInt n1, VInt n2 -> VInt (n1*n2)
								   | _ -> failwith "Malformed expression.")))
  | TVar s -> k (snd (List.find (fun (s',_) -> s = s') c))
  | TFun (s,t) -> k (VFun (s,t))
  | TApp (t1,t2) -> eval t1 c (fun v1 ->
				 match v1 with 
				   | VFun (s,t') -> eval t2 c (fun v2 -> eval t' ((s,v2)::c) k)
				   | VCont k' -> eval t2 c k'
				   | _ -> failwith "Malformed expression.")
  | TTryWith (tt,s,tw) -> eval tt (("__raise__", VCont (fun v -> eval tw ((s,v)::c) k))::c) k
  | TRaise t -> eval (TApp (TVar "__raise__", t)) c k;;

let print v = match v with
  | VInt n  -> print_int n
  | VFun _  -> print_string "<fun>"
  | VCont _ -> print_string "<cont>";;

let expr = TTryWith (TAdd (TRaise (TInt 3), TInt 9),
		     "x", TMul (TVar "x", TInt 2))
and context = []
in eval expr context print;;



(******************************************************************************)
(* 3. Programmation parallèle, ou comment faire à plusieurs *******************)
(******************************************************************************)

(* 3.2. La base ***************************************************************)

let fifo = Queue.create ();;
Random.self_init ()

let cc () = try Queue.pop fifo () with Queue.Empty -> ()

let fork p k =
  if Random.bool () then (Queue.push (fun () -> p cc) fifo; k ())
  else (Queue.push k fifo; p cc);;

let yield k =
  if Random.bool () then (Queue.push k fifo; cc ())
  else (k (); cc ());;

let thread i k' = print_int i; print_newline (); k' () in
let rec prog i k =
  fork 
    (thread i)
    (fun () -> if i > 0 then prog (i - 1) k else k ())
in prog 100 (fun () -> ());;


(* 3.3. Une mémoire partagée **************************************************)

let memory = Array.make 16 0;;

let read i k =
  k memory.(i);;

let write i x k =
  memory.(i) <- x; k ();;

let clear () =
  Array.fill memory 0 (Array.length memory) 0;;

let thread i k' =
  let incr x k = k (x+1)
  and print x k = print_int x; print_newline (); k ()
  in read 0
       (fun x -> yield
	  (fun () -> incr x
	     (fun x -> write 0 x
		(fun () -> print x k')))) in
let rec prog i k =
  fork 
    (thread i)
    (fun () -> if i > 0 then prog (i - 1) k else k ())
in clear (); prog 100 (fun () -> ());;


(* 3.4. Cohérence et sémaphores ***********************************************)

type semaphore = {
  mutable free: bool;
  fifo: (unit -> unit) Queue.t
};;

let sem_p s k =
  if s.free then (s.free <- false; k ())
  else Queue.push k s.fifo; cc ();;

let sem_v s k =
  s.free <- true;
  Queue.push (fun () -> sem_p s (Queue.pop s.fifo)) fifo;
  k (); cc ();;

let s = { free = true; fifo = Queue.create () };;

let thread i k' =
  let incr x k = k (x+1)
  and print x k = print_int x; print_newline (); k ()
  in sem_p s
       (fun () -> read 0
	  (fun x -> yield
	     (fun () -> incr x
		(fun x -> write 0 x
		   (fun () -> print x
		      (fun () -> sem_v s k')))))) in
let rec prog i k =
  fork 
    (thread i)
    (fun () -> if i > 0 then prog (i - 1) k else k ())
in clear (); prog 100 (fun () -> ());;