(* Cache *)

module type S =
  sig
    type key
    type thing
    type t
    val create : int option -> t
    val find : t -> key -> thing
    val mem : t -> key -> bool
    val add : t -> key -> thing -> unit
    val remove : t -> key -> unit
  end
;;

module Make(K:Map.OrderedType)(T:Map.OrderedType) =
  struct
    type key = K.t;;
    type thing = T.t;;
    type elt = {
      mutable priority : int;
      key : key;
      thing : thing;
      };;
        
    let comparator a x y = compare (a x) (a y);;

    let product_compare c1 c2 x y = let r = c1 x y in if r = 0 then c2 x y else r;;

    let compare_elements =
      product_compare
      (comparator (fun x -> x.priority))
      (product_compare
         (fun x y -> K.compare x.key y.key)
         (fun x y -> T.compare x.thing y.thing))
    ;;

    module KM = Map.Make(K);;
    module ES = Set.Make(struct type t = elt let compare = compare_elements end);;

    type t = {
      maximum_size : int;
      mutable current_size : int;
      mutable elements : ES.t;
      mutable map : elt KM.t;
      mutable decay_counter : int;
      mutable accesses : int;
      mutable hits : int
    };;

    let create m =
      { maximum_size = (match m with None -> (-1)|Some(x) -> x);
        current_size = 0; elements = ES.empty; map = KM.empty; decay_counter = 0;
        accesses = 0; hits = 0 }
    ;;

    let decay c =
      let l = ES.elements c.elements in
      List.iter (fun e -> e.priority <- e.priority / 2) l;
      c.elements <- List.fold_right ES.add l ES.empty
    ;;

    let statistics c =
      (c.accesses, c.current_size,
       if c.accesses > 0 then
         (float_of_int) c.hits /. (float_of_int) c.accesses
       else
         0.0)
    ;;

    let find c k =
      c.accesses <- c.accesses + 1;
      let e = KM.find k c.map in
      c.hits <- c.hits + 1;
      c.elements <- ES.remove e c.elements;
      if e.priority < max_int then e.priority <- e.priority + 1;
      c.elements <- ES.add e c.elements;
      c.decay_counter <- c.decay_counter + 1;
      if c.decay_counter >=
          (if c.maximum_size < 0 then
             2 * c.current_size
           else
             2 * c.maximum_size)
      then
        begin
          c.decay_counter <- 0;
          decay c
        end;
      e.thing
    ;;

    let remove c k =
      let e = KM.find k c.map in
      c.elements <- ES.remove e c.elements;
      c.current_size <- c.current_size - 1;
      c.map <- KM.remove k c.map
    ;;

    let mem c k =
      try
        ignore (find c k); true
      with
      | Not_found -> false
    ;;

    let kick c =
      let e = ES.min_elt c.elements in
      c.elements <- ES.remove e c.elements;
      c.current_size <- c.current_size - 1;
      c.map <- KM.remove e.key c.map
    ;;

    let add c k t =
      if c.maximum_size <> 0 then
      begin
        if c.current_size = c.maximum_size then
        kick c;
        let e =
          { priority = (if c.current_size > 0 then (ES.max_elt c.elements).priority + 1 else 1);
            key = k;
            thing = t }
        in
        c.elements <- ES.add e c.elements;
        c.current_size <- c.current_size + 1;
        c.map <- KM.add k e c.map
      end
    ;;
  end
;;
