lib/cml/util/fun-priority-queue.fun

   1 (* fun-queue.sml
   2  * 2004 Matthew Fluet (mfluet@acm.org)
   3  *  Ported to MLton threads.
   4  *)
   5
   6 functor FunPriorityQueue(S: FUN_PRIORITY_QUEUE_ARG) :
   7    FUN_PRIORITY_QUEUE where type Key.t = S.Key.t =
   8    struct
   9       open S
  10
  11       structure Elt =
  12          struct
  13             datatype 'a t = T of Key.t * 'a
  14             fun key (T (k, _)) = k
  15             fun value (T (_, v)) = v
  16          end
  17
  18       datatype 'a t = T of 'a Elt.t list
  19
  20       local
  21          fun filterPrefix (xs, p) =
  22             case xs of
  23                [] => []
  24              | y::ys => if p y
  25                           then filterPrefix (ys, p)
  26                           else xs
  27          fun filter (xs, p) = List.filter (not o p) xs
  28       in
  29          fun cleanPrefix (T xs, p) = T (filterPrefix (xs, p))
  30          fun clean (T xs, p) = T (filter (xs, p))
  31       end
  32
  33       fun deque (T xs) =
  34          (case xs of
  35              [] => NONE
  36            | x::xs => SOME (x, T xs))
  37
  38       fun cleanAndDeque (q, p) =
  39          let
  40             val q = clean (q, p)
  41          in
  42             case deque q of
  43                NONE => (NONE, q)
  44              | SOME (x, q) => (SOME x, q)
  45          end
  46
  47       fun empty (T xs) =
  48          (case xs of
  49              [] => true
  50            | _ => false)
  51
  52       fun enque (T xs, k', v') =
  53          let
  54             val x' = Elt.T (k', v')
  55             fun loop (xs, ys) =
  56                case xs of
  57                   [] => List.revAppend(ys, [x'])
  58                 | (z as Elt.T (k, _))::zs =>
  59                      (case Key.compare (k, k') of
  60                          GREATER => List.revAppend(ys, x'::xs)
  61                        | _ => loop(zs, z::ys))
  62          in
  63             T (loop (xs, []))
  64          end
  65
  66       fun enqueAndClean (q, k, v, p) =
  67          clean (enque (q, k, v), p)
  68
  69       fun new () = T []
  70
  71       fun peek (T xs) =
  72          (case xs of
  73              [] => NONE
  74            | elt::_ => SOME elt)
  75    end