lru!

lru.ml

module Option = struct
  let (>>=) a fb = match a with Some x -> fb x | _ -> None
  let (>|=) a f  = match a with Some x -> Some (f x) | _ -> None
end

type ('k, 'v) tree =
  | Tip
  | Node of 'k * 'v * int * ('k, 'v) tree * ('k, 'v) tree

type ('k, 'v) t = { gen  : int ; size : int ; tree : ('k, 'v) tree }

let rec adjoin t1 t2 = match (t1, t2) with
  | (_, Tip) -> t1
  | (Tip, _) -> t2
  | (Node (k1, v1, g1, l1, r1), Node (k2, v2, g2, l2, r2)) ->
      if g1 < g2 then
        Node (k1, v1, g1, l1, adjoin r1 t2)
      else Node (k2, v2, g2, adjoin t1 l2, r2)

let remove k t =
  let open Option in
  let rec go k1 = function
    | Tip -> None
    | Node (k, v, g, l, r) ->
        match compare k1 k with
        | -1 -> go k1 l >|= fun (x, l) -> (x, Node (k, v, g, l, r))
        |  1 -> go k1 r >|= fun (x, r) -> (x, Node (k, v, g, l, r))
        |  _ -> Some (v, adjoin l r) in
  go k t.tree >|= fun (x, tree) -> (x, { t with tree ; size = t.size - 1 })

let add k v ({ gen; _ } as t) =
  let rec go k1 v1 = function
    | Tip -> Node (k1, v1, gen, Tip, Tip)
    | Node (k, v, g, l, r) ->
        if k1 <= k then
          Node (k, v, g, go k1 v1 l, r)
        else Node (k, v, g, l, go k1 v1 r) in
  { tree = go k v t.tree ; gen = gen + 1 ; size = t.size + 1 }

let find k t = Option.(remove k t >|= fun (x, t) -> (x, add k x t))

let oldest t = match t.tree with
  | Tip -> None
  | Node (k, v, _, _, _) -> Some (k, v)

let drop t = match t.tree with
  | Tip -> None
  | Node (_, _, _, l, r) ->
      Some { t with tree = adjoin l r ; size = t.size - 1 }

let size t = t.size

mlru.ml

module Dequeue = struct

  type 'a node = {
    contents : 'a ;
    mutable next : 'a node option ;
    mutable prev : 'a node option
  }

  type 'a t = {
    mutable first : 'a node option ;
    mutable last  : 'a node option
  }

  let detach t n =
    let np = n.prev and nn = n.next in
    ( match np with
      | None   -> t.first <- nn
      | Some x -> x.next <- nn ; n.prev <- None );
    ( match nn with
      | None   -> t.last <- np
      | Some x -> x.prev <- np ; n.next <- None )

  let append t n =
    let on = Some n in
    match t.last with
    | Some x as l -> x.next <- on ; t.last <- on ; n.prev <- l
    | None        -> t.first <- on ; t.last <- on

  let fresh x = { contents = x ; prev = None ; next = None }

  let create () = { first = None ; last = None }
end

type ('a, 'b) t = {
  ht : ('a, ('a * 'b) Dequeue.node) Hashtbl.t ;
  dq : ('a * 'b) Dequeue.t ;
}

let create () = { ht = Hashtbl.create 16 ; dq = Dequeue.create () }

let oldest t =
  match t.dq.Dequeue.first with
  | Some n -> Some n.Dequeue.contents
  | None   -> None

let size t = Hashtbl.length t.ht

let add k v t =
  let n = Dequeue.fresh (k, v) in
  Hashtbl.add t.ht k n;
  Dequeue.append t.dq n

let remove k t =
  try
    let n = Hashtbl.find t.ht k in
    Hashtbl.remove t.ht k;
    Dequeue.detach t.dq n
  with Not_found -> ()

let find k t =
  try
    let n = Hashtbl.find t.ht k in
    Dequeue.( detach t.dq n; append t.dq n );
    Some (snd n.Dequeue.contents)
  with Not_found -> None