fun_cost.ml

module type Arrow =
sig
  type ('a,'b) t
  val arr   : ('a -> 'b) -> ('a, 'b) t
  val (>>>) : ('a,'b) t -> ('b,'c) t -> ('a,'c) t
  val first : ('a,'b) t -> ('a * 'c, 'b * 'c) t
end

module type Arrow_choice =
sig
  include Arrow
  val (<+>) : ('a,'b) t -> ('a,'b) t -> ('a,'b) t
  val apply : ('a,'b) t -> 'a -> 'b
  val cost  : ('a,'b) t -> int
end

module Fun_cost : Arrow_choice =
struct
  type ('a,'b) t = T of ('a -> 'b) * int

  let arr f = T (f, 1)

  let (>>>) (T (f, i)) (T (g, j)) =
    let h = fun x -> g (f x) in
    T (h, i + j)

  let first (T (f, i)) =
    let g = fun (x,y) -> (f x, y) in
    T (g, i)

  (** Choose the function with minimum cost. *)
  let (<+>) (T (f, i)) (T (g, j)) =
    (* Avoids space leak! *)
    if i < j then T (f, i) else T (g, j)

  let apply (T (f, _)) = f

  let cost (T (_, i)) = i
end

let () = Random.self_init ()

open Fun_cost

let c1 = arr (fun x -> List.length x > 0)
let _ = Printf.printf "cost of c1 = %d\n" @@ cost c1

let c2 = arr (fun y -> Printf.sprintf "%B" y)
let _ = Printf.printf "cost of c2 = %d\n" @@ cost c2

let c12 = c1 >>> c2
let _ = Printf.printf "cost of c12 = %d\n" @@ cost c12

let c3 = arr (fun l -> String.concat " " (List.map string_of_int l))
let _ = Printf.printf "cost of c3 = %d\n" @@ cost c3

let c12or3 = c12 <+> c3
let _ = Printf.printf "cost of c12or3 = %d\n" @@ cost c12or3

let () = print_endline @@ (apply c12or3) [1;2;3]