open Mcupto;;

module Test (Cupto : Cupto) : sig end = struct

open Cupto;;

let prc s = print_string s; print_string " =? ";;
let prs s = print_string s; print_newline();;
let pri i = print_int i; print_newline();;

prs "(* Matthias's exercice *)";;

type tree = Node of int * tree * tree | Null

let p = new_prompt ();;

let resume = ref (fun x -> x);;

let rec walk = function 
     Null -> 999
  |  (Node (v,t1,t2)) -> 
       cupto p (fun k -> (resume := (fun x ->
         (ignore (walk t1); ignore (walk t2); k 999));
                         v))

let get_first t = set p (fun () -> walk t)
let get_next () = set p (fun () -> (!resume) 999)
    
let test = Node (1, Node (2,Node (3,Null,Null),Node (4,Null,Null)),
                    Node (5,Null,Node(6,Node(7,Null,Null),Null)));;

pri (get_first test);;
pri (get_next());;
pri (get_next());;
pri (get_next());;
pri (get_next());;
pri (get_next());;
pri (get_next());;
pri (get_next());;

prs "(* compatibility of cupto with primitive exceptions *)";;

exception Foo of int;;


let p = new_prompt();;

let f b = 
  10000 + 
  set p (fun _ -> 
    try 
       10 +
       set p (fun _ -> if b then 3 else raise (Foo 5))
    with 
       Foo x -> 
       100 + x
  );;
       
prc "10013"; pri (f true);;
prc "10105"; pri (f false);;
 
prs "(* testing correct removal of prompts when cupto-ing *)"

let f b = 
  10000 + 
  set p (fun _ -> 
    10 +
    set p (fun _ -> 
      100 + 
      set p (fun _ -> 
        1000 + 
        cupto p (fun x ->
          (* x should be equivalent to fun z -> z + 1000 
             i.e. it should not set any mark *)
          x  
          (if b then cupto p (fun y -> y (y 3)) else 5)
        )
  )));;

 
prc "12213"; pri (f true);;
prc "11115"; pri (f false);;
 
 
prs "(* cc_to_fun and back *)"
   
let apply f a = 
  set p (fun () -> f (cupto p (fun k -> k a)))

let cc_to_fun p cc =
  fun a ->
    set p (fun () -> cc (a, p))
;;

let fun_to_cc q (f : 'a -> 'b) =
  let p = (new_prompt() : 'b) in
    set p 
      (fun () ->
         let (a,r) =
           cupto p (fun cc -> cupto q (fun z -> cc))
         in cupto r (fun z -> f a))
;;

(*
let cc_to_fun p cc = 
  let p = new_prompt() in
  set p (fun () -> 
           fun a -> cupto p (fun k -> cc (a,k)))
;;
print_string "fun_to_cc OK"; print_newline();;

(*
let cc = fun_to_cc (fun x -> x * x);;
print_string "cc OK"; print_newline();;

print_int (cc 5);;
print_string " (cc 5)"; print_newline();;
*)
*)

end;;


module T0 = Test (Cupto);;
module T1 = Test (Mcupto (Cupto));;
module T2 = Test (Mcupto (Mcupto (Cupto)));;

module Test5 (M : Cupto) = Mcupto (Mcupto (Mcupto (Mcupto (Mcupto (M)))));;

module T5 = Test (Test5 (Cupto));;
module T10 = Test (Test5 (Test5 (Cupto)));;