qc.ml

(* TODO: use Random.State *)
open Random;;
open List;;

(* =========================================== General Utils = *)
let sign x = if x < 0 then -1 else 1;;

let truncate x l = sign x * min (abs x) l;;

let id (a: 'a) = a;;
let (--) i j =
  let rec go acc n = if n < i
                     then acc
                     else go (n :: acc) (n - 1)
  in go [] j;;
                           
             
let comp (f: 'b -> 'c) (g: 'a -> 'b) (x: 'a) = f (g x);;

let flip f y x = f x y;;

let rec duplicate x = function
  | 0 -> []
  | n -> x :: duplicate x (n - 1);;

let iterate f z =
  let rec go acc = function
    | None        -> acc
    | Some (a, b) -> go (a :: acc) (f b)

  in go [] (f z);;

let rec take n xs = match (n, xs) with
  | (_, []) -> []
  | (0, _)  -> []
  | (n, x::xs) -> x :: take (n-1) xs;;
                            
let rec drop n xs = match (n, xs) with
  | (_, []) -> []
  | (0, xs) -> xs
  | (n, _::xs) -> drop (n-1) xs;;

let rec repeat n f = match n with
  | 0 -> ()
  | n -> let _ = f () in repeat (n - 1) f;; 

let rec repeat_with_stop n f = match n with
  | 0 -> ()
  | n -> if f ()
         then repeat_with_stop (n - 1) f
         else ();; 

let first_some l r = match l with
  | None -> r
  | _ -> l;;

let maybe v = function
  | Some w -> w
  | _      -> v;;

let rescue_with x m = Some (maybe x m);;


let rec find_first p = function
  | [] -> None
  | x :: xs -> let m = p x
    in match m with
    | Some _ -> m
    | _      -> find_first p xs;;

(* =========================================== Defered = *)
type 'a defered =
  | Thunk of (unit -> 'a)
  | Val   of 'a;;

let force = function
  | Thunk d -> d ()
  | Val v   -> v;;

let map_defered f = function
  | Thunk g -> Thunk (comp f g)
  | Val   a -> Val (f a);;

let apply_defered f l r = match (l, r) with
  | (Val x, Val y) -> Val (f x y)
  | (l, r)         -> Thunk (fun _ -> f (force l) (force r));;

let ret_defered x = Val x;;

let bind_defered m f = match m with
  | Thunk d -> Thunk (fun _ -> force (f (d ())))
  | Val x   -> f x;;
                      

(* =========================================== Rose Tree = *)
type 'a rose = {
  root: 'a;
  children: 'a rose list defered;
};;

let rec map_rose f r = {
  root=f r.root;
  children= map_defered (List.map (map_rose f)) r.children
};;

let ret_rose a = { root=a; children= ret_defered []};;

let rec bind_rose (r : 'a rose) (f: 'a -> 'b rose) : ' b rose =
  let froot = f r.root in
  { root= froot.root;
    children= apply_defered (@)
        froot.children
        (map_defered (List.map (flip bind_rose f)) r.children)
  };;


(* =========================================== Show = *)
type 'a show = 'a -> string;;
  
let show_int = string_of_int;;
let show_bool = string_of_bool;;
let show_pair sl sr (l, r) = "(" ^ sl l ^ ", " ^ sr r ^ ")";;
let show_str = id;;
let show_list s l = "[ " ^
                    List.fold_left (fun r l -> s l ^ " " ^ r) "" l ^
                    "]";;

let rec show_rose s n r =
       let rest = if n <= 0
         then "[...]"
         else (show_list (show_rose s (n - 1))) (force r.children)

       in "{ root= " ^ s r.root ^ ", " ^ "children= " ^ rest ^ " }";;

(* =========================================== Gen Monad = *)

(* Int param is the term size constraint *)
type 'a gen = int -> 'a rose;;

let bind_gen (g : 'a gen) (f: 'a -> 'b gen) : 'b gen = fun i ->
   bind_rose
     (g i)
     (fun a -> f a i);;

let ret_gen (a : 'a) _ = ret_rose a;;

let map_gen (f : 'a -> 'b) (g: 'a gen) i = map_rose f (g i);;

(* =========================================== Combinators = *)
let shrink_int n = {
  root=n;
  children=
    let it z = if z == 0
      then None
      else Some (z/2, z/2) in
    let f _  = List.map ret_rose (iterate it n)
    in Thunk f
};;


let choose lo hi size =
  let sized_lo = truncate lo size in
  let sized_hi = truncate hi size in
  let n = sized_lo + Random.int (sized_hi - sized_lo + 1)
  in shrink_int n;;

let element (xs : 'a list) : ('a gen) = map_gen (nth xs) (choose 0 (length xs - 1));;
  
let oneof (gens : 'a gen list) : 'a gen = bind_gen (element gens) id;;
  
let frequency (gens : (int * 'a gen) list) : 'a gen =
  let universe = fold_left (fun n (f, _) -> n + f) 0 gens in
  let rec pick ((k, gen) :: xs) n = if   n <= k
                                    then gen
                                    else pick xs (n - k)
  in bind_gen (choose 1 universe) (pick gens);;

let sized (f : int -> 'a gen) i = f i i;;
let resize n gen _ = gen n;;

(* =========================== Arbitrary instances = *)

let gen_bool = element [false; true];;

let gen_int = sized (fun i -> choose (-i) i);;

let gen_pair (genl: 'a gen) (genr: 'b gen) : ('a * 'b) gen = fun i ->
  let l = genl i in
  let r = genr i in

  let rec shrink (l, r) =
    let pl l = (ret_rose l, r) in
    let pr r = (l, ret_rose r) in

    let map_children f = List.map (map_rose f) in

    let unshrinked_children = apply_defered (@)
          (map_defered (map_children pl) l.children)
          (map_defered (map_children pr) r.children)
       
    in { root=(l.root, r.root);
         children= map_defered (List.map (flip bind_rose shrink)) unshrinked_children
       }
  in shrink (l, r)
;;


(* ================================================== Property = *)
  
type result = { ok: bool option; arguments: string list };;
type property = Prop of result gen;;
type 'a testable = { prop: ('a -> property) };;

let nothing = { ok=None; arguments=[] };;
let res r = Prop (ret_gen r);;
let evaluate { prop; } a = let Prop gen = prop a in gen;;

let forall ((testableb, gena, showa) : 'b testable * 'a gen * 'a show) f =
  Prop (bind_gen gena
             (fun a -> bind_gen (evaluate testableb (f a))
             (fun r -> ret_gen ({ r with arguments = (showa a) :: r.arguments})
             )));;
                              
let bool_testable = {
    prop = fun b -> res ({ nothing with ok = Some b})
};;


let prop_testable = {
  prop = id
};;

let fun_testable classes : ('a -> 'b) testable = {
    prop= fun f -> forall classes f
};;

let predicate_testable (arb, show) = fun_testable (bool_testable, arb, show);;

let to_prop_testable (arb, show) = fun_testable (prop_testable, arb, show);;

let quickcheck (testablea: 'a testable) (a: 'a) =
  let gen = evaluate testablea a in

  let failed {root= {ok}} = (match ok with
      | None | Some true -> false
      | Some false       -> true
    ) in

  let rec find_smallest_fail case =
    if failed case
    then
      let smallest_child = find_first find_smallest_fail (force case.children)
      in rescue_with case smallest_child
    else None
  in
  
  let run_one _ =
    let case = gen 30 in
    (match find_smallest_fail case with
     | None -> true
     | Some { root={arguments}} ->
       let str = "failed with: " ^ (show_list show_str) arguments  ^ "\n" in
       let _   = print_string str in

       false
    )    
  in repeat_with_stop 100 run_one
;;


let (==>) pre post =
  if pre
  then bool_testable.prop post
  else res nothing;;

let quickcheckb = comp quickcheck predicate_testable;; 
let quickcheckp = comp quickcheck to_prop_testable;;

Random.self_init ();;


























(* ================================================== Test Code = *)

let swap (l, r) = (r, l);;
let eq (ll, lr) (rl, rr) = ll == rl && lr == rr;;

let property x = let (l, r) = x in
  l > 1 ==> eq (swap x) x;;

quickcheckp
  (resize 100 (gen_pair gen_int gen_int), show_pair show_int show_int)
  property;;