An implementation of Real-Time Deques in PFDS (Chapter 8.4.3)

realTimeDeque.ml

module type ITEM =
sig
  type t
  val print : t -> unit
end

module type ORDERED = 
sig
  include ITEM

  val eq  : t * t -> bool
  val lt  : t * t -> bool
  val leq : t * t -> bool
end

module Int : (ORDERED with type t = int) =
struct
  type t = int
  
  let eq  (x,y) = x == y
  let lt  (x,y) = x <  y
  let leq (x,y) = x <= y

  let print = print_int
end

module type RQUEUE =
sig
  module Elem : ITEM

  type queue
  
  exception Empty

  val empty : queue
  val isEmpty : queue -> bool
  
  val snoc : queue -> Elem.t -> queue
  val head : queue -> Elem.t (* raises Empty if queue is empty *)
  val tail : queue -> queue (* raises Empty if queue is empty *)

  val print : queue -> unit
  val dprint : bool -> queue -> unit
end

module type RDEQUE =
sig
  include RQUEUE

  val cons : Elem.t -> queue -> queue
  val last : queue -> Elem.t (* raises Empty if queue is empty *)
  val init : queue -> queue (* raises Empty if queue is empty *)
end

module type SMALLSTREAM =
sig
  type 'a cell = Nil | Cons of 'a * 'a stream
  and  'a stream = 'a cell Lazy.t;;

  val (++) : 'a stream -> 'a stream -> 'a stream
  val take : int * 'a stream -> 'a stream
  val drop : int * 'a stream -> 'a stream
  val reverse : 'a stream -> 'a stream
end

module SmallStream : SMALLSTREAM =
struct
  type 'a cell = Nil | Cons of 'a * 'a stream
  and  'a stream = 'a cell Lazy.t;;

  let rec (++) t1 t2 = lazy (match (t1, t2) with
    | (lazy Nil, lazy t2) -> t2
    | (lazy (Cons(x, s)), t2) -> Cons (x, s ++ t2))
  ;;

  let rec take (n, s) = lazy (match (n, s) with
    | (0, _) -> Nil
    | (_, lazy Nil) -> Nil
    | (n, lazy (Cons (x, s))) -> Cons (x, take ((n-1), s)))
  ;;

  let drop (n, s) = lazy (
    let rec drop' n s = match (n, s) with
      | (0, lazy s) -> s
      | (_, lazy Nil) -> Nil
      | (n, lazy (Cons (_, s))) -> drop' (n-1) s
    in drop' n s)
  ;;

  let reverse xs = lazy (
    let rec reverse' xs r = match (xs, r) with
      | (lazy Nil, r) -> r
      | (lazy (Cons (x, xs')), r) -> reverse' xs' (Cons (x, lazy r))
    in reverse' xs Nil)
  ;;
end

module type CONSTNUM =
sig
  val c : int
end

module RealTimeDeque (Element : ITEM) (ConstNum : CONSTNUM) : RDEQUE
  with module Elem = Element =
struct
  module Elem = Element
  module S = SmallStream

  type queue = int * Elem.t S.stream * Elem.t S.stream
             * int * Elem.t S.stream * Elem.t S.stream
  
  exception Empty

  let c = ConstNum.c
  ;;

  let empty = (0, lazy S.Nil, lazy S.Nil, 0, lazy S.Nil, lazy S.Nil)
  ;;

  let isEmpty (lenf, f, sf, lenr, r, sr) = (lenf + lenr == 0)
  ;;

  let exec1 s =
    let exec1 = function
      | (lazy (S.Cons (x, s))) -> print_string " - Cons)\n"; s
      | s -> print_string " - Nil)\n"; s in
    if Lazy.lazy_is_val s then
      print_string "called exec (inaction"
    else
      print_string "called exec (forced -\n";
    exec1 s
  ;;

  let exec2 s = exec1 (exec1 s)
  ;;

  let concat s1 s2 =
    print_string "called concat\n";
    S.(++) s1 s2
  ;;

  let rev s =
    print_string "called rev\n";
    S.reverse s
  ;;

  let drop p =
    print_string "called drop\n";
    S.drop p
  ;;

  let rec rotateRev = function
    | (lazy S.Nil, r, a) -> 
        print_string "called rotateRev (A)\n";
        concat (rev r) a
    | (lazy (S.Cons (x, f)), r, a) ->
        print_string "called rotateRev (B)\n";
        lazy (S.Cons (x, rotateRev (f, drop (c, r), concat (rev (S.take (c, r))) a)))
  ;;

  let rec rotateDrop (f, j, r) =
    print_string "called rotateDrop j=";
    print_int j;
    print_string ", c=";
    print_int c;
    print_string " ##\n";
    if j < c then
      rotateRev (f, drop (j, r), lazy S.Nil)
    else
      let (lazy (S.Cons (x, f'))) = f in
      lazy (S.Cons (x, rotateDrop (f', j - c, drop (c, r))))
  ;;

  let check ((lenf, f, sf, lenr, r, sr) as q) =
    if lenf > c * lenr + 1 then
      let i = (lenf + lenr) / 2 in
      let j = lenf + lenr - i in
      let f' = S.take (i, f) in
      let r' = rotateDrop (r, i, f) in
      (i, f', f', j, r', r')
    else if lenr > c * lenf + 1 then
      let j = (lenf + lenr) / 2 in
      let i = lenf + lenr - j in
      let r' = S.take (j, r) in
      let f' = rotateDrop (f, j, r) in
      (i, f', f', j, r', r')
    else q
  ;;

  let cons x (lenf, f, sf, lenr, r, sr) =
    check (lenf + 1, lazy (S.Cons (x, f)), exec1 sf, lenr, r, exec1 sr)
  ;;

  let head = function
    | (lenf, lazy S.Nil, sf, lenr, lazy S.Nil, sr) -> raise Empty
    | (lenf, lazy S.Nil, sf, lenr, lazy (S.Cons (x, _)), sr) -> x
    | (lenf, lazy (S.Cons (x, f')), sf, lenr, r, sr) -> x
  ;;

  let tail q =
    let tail = function
      | (lenf, lazy S.Nil, sf, lenr, lazy S.Nil, sr) -> raise Empty
      | (lenf, lazy S.Nil, sf, lenr, lazy (S.Cons (x, _)), sr) -> empty
      | (lenf, lazy (S.Cons (x, f')), sf, lenr, r, sr) ->
          check (lenf - 1, f', exec2 sf, lenr, r, exec2 sr) in
    print_string "called tail\n";
    tail q
  ;;

  let reverse (lenf, f, sf, lenr, r, sr) = (lenr, r, sr, lenf, f, sf)
  ;;

  let snoc q x =
    print_string "called snoc\n"; 
    reverse (cons x (reverse q))
  ;;

  let last q = head (reverse q)
  ;;

  let init q = reverse (tail (reverse q))
  ;;

  let dprint show (lenf, f, sf, lenr, r, sr) =
    let rec print_elem_stream s =
      let print_elem_stream_val = function
        | (lazy S.Nil) -> print_string "Nil"
        | (lazy (S.Cons (x, xs))) ->
            print_string "Cons (";
            Elem.print x;
            print_string ", ";
            print_elem_stream xs;
            print_string ")" in
      if show || Lazy.lazy_is_val s then
        print_elem_stream_val s
      else
        print_string "SUSP" in
    print_string "queue\n\t(";
    print_int lenf;
    print_string ",\n\t";
    print_elem_stream f;
    print_string ",\n\t";
    print_elem_stream sf;
    print_string ",\n\t";
    print_int lenr;
    print_string ",\n\t";
    print_elem_stream r;
    print_string ",\n\t";
    print_elem_stream sr;
    print_string ")";
    print_newline ()
  ;;
  
  let print q = dprint false q
  ;; 
end

module Q = RealTimeDeque (Int) (struct let c = 3 end) 

(*************************************************
 *  helper function for testing
 *************************************************)

let make_queue n =
  let rec make_queue n i q =
    if i < n
    then make_queue n (i+1) (Q.snoc q i)
    else q
  in make_queue n 0 Q.empty
;;

let snoc_queue n q =
  let rec snoc_queue n i q =
    if i < n
    then snoc_queue n (i+1) (Q.snoc q (i*(-1)))
    else q
  in snoc_queue n 0 q
;;

let tail_queue n q =
  let rec tail_queue n i q =
    if i < n
    then tail_queue n (i+1) (Q.tail q)
    else q
  in tail_queue n 0 q
;;

let qprint = Q.dprint false
;;

let dqprint = Q.dprint true
;;

(*************************************************
 *  Tests
 *************************************************)

print_string "----------------------------------------\n";

print_string "n=24:\n";;
let queue_24 = snoc_queue 2 (tail_queue 1 (make_queue 23));;
qprint queue_24;;
let queue_23 = Q.tail queue_24;;
print_string "n=23:\n"; qprint queue_23;;
print_string "n=14:\n"; qprint (tail_queue 9 queue_23);;

print_string "----------------------------------------\n";;

results

        Objective Caml version 3.12.1

#                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       * *                 module type ITEM = sig type t val print : t -> unit end
module type ORDERED =
  sig
    type t
    val print : t -> unit
    val eq : t * t -> bool
    val lt : t * t -> bool
    val leq : t * t -> bool
  end
module Int :
  sig
    type t = int
    val print : t -> unit
    val eq : t * t -> bool
    val lt : t * t -> bool
    val leq : t * t -> bool
  end
module type RQUEUE =
  sig
    module Elem : ITEM
    type queue
    exception Empty
    val empty : queue
    val isEmpty : queue -> bool
    val snoc : queue -> Elem.t -> queue
    val head : queue -> Elem.t
    val tail : queue -> queue
    val print : queue -> unit
    val dprint : bool -> queue -> unit
  end
module type RDEQUE =
  sig
    module Elem : ITEM
    type queue
    exception Empty
    val empty : queue
    val isEmpty : queue -> bool
    val snoc : queue -> Elem.t -> queue
    val head : queue -> Elem.t
    val tail : queue -> queue
    val print : queue -> unit
    val dprint : bool -> queue -> unit
    val cons : Elem.t -> queue -> queue
    val last : queue -> Elem.t
    val init : queue -> queue
  end
module type SMALLSTREAM =
  sig
    type 'a cell = Nil | Cons of 'a * 'a stream
    and 'a stream = 'a cell Lazy.t
    val ( ++ ) : 'a stream -> 'a stream -> 'a stream
    val take : int * 'a stream -> 'a stream
    val drop : int * 'a stream -> 'a stream
    val reverse : 'a stream -> 'a stream
  end
module SmallStream : SMALLSTREAM
module type CONSTNUM = sig val c : int end
module RealTimeDeque :
  functor (Element : ITEM) ->
    functor (ConstNum : CONSTNUM) ->
      sig
        module Elem : sig type t = Element.t val print : t -> unit end
        type queue
        exception Empty
        val empty : queue
        val isEmpty : queue -> bool
        val snoc : queue -> Elem.t -> queue
        val head : queue -> Elem.t
        val tail : queue -> queue
        val print : queue -> unit
        val dprint : bool -> queue -> unit
        val cons : Elem.t -> queue -> queue
        val last : queue -> Elem.t
        val init : queue -> queue
      end
module Q :
  sig
    module Elem : sig type t = Int.t val print : t -> unit end
    type queue
    exception Empty
    val empty : queue
    val isEmpty : queue -> bool
    val snoc : queue -> Elem.t -> queue
    val head : queue -> Elem.t
    val tail : queue -> queue
    val print : queue -> unit
    val dprint : bool -> queue -> unit
    val cons : Elem.t -> queue -> queue
    val last : queue -> Elem.t
    val init : queue -> queue
  end
val make_queue : Q.Elem.t -> Q.queue = <fun>
#               val snoc_queue : int -> Q.queue -> Q.queue = <fun>
#               val tail_queue : int -> Q.queue -> Q.queue = <fun>
#     val qprint : Q.queue -> unit = <fun>
#     val dqprint : Q.queue -> unit = <fun>
#   * *         ----------------------------------------
n=24:
- : unit = ()
# called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called rotateDrop j=1, c=3 ##
called drop
called rotateRev (A)
called rev
called concat
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Nil)
called exec (forced -
 - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called rotateDrop j=3, c=3 ##
called snoc
called exec (forced -
called drop
called rotateDrop j=0, c=3 ##
called drop
called rotateRev (A)
called rev
called concat
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Nil)
called exec (forced -
 - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called rotateDrop j=7, c=3 ##
called snoc
called exec (forced -
called drop
called rotateDrop j=4, c=3 ##
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
called drop
called rotateDrop j=1, c=3 ##
called drop
called rotateRev (B)
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
called rev
called concat
called drop
called rotateRev (A)
called rev
called concat
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called snoc
called exec (forced -
 - Nil)
called exec (forced -
 - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called tail
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
called snoc
called exec (inaction - Nil)
called exec (inaction - Nil)
val queue_24 : Q.queue = <abstr>
# queue
	(6,
	Cons (1, Cons (2, Cons (3, Cons (4, Cons (5, Cons (6, Nil)))))),
	Nil,
	18,
	SUSP,
	Nil)
- : unit = ()
# called tail
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called rotateDrop j=11, c=3 ##
val queue_23 : Q.queue = <abstr>
# n=23:
queue
	(12,
	SUSP,
	SUSP,
	11,
	SUSP,
	SUSP)
- : unit = ()
# n=14:
called tail
called drop
called rotateDrop j=8, c=3 ##
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (inaction - Cons)
called exec (forced -
called drop
called rotateDrop j=5, c=3 ##
 - Cons)
called tail
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
called drop
called rotateDrop j=2, c=3 ##
called drop
called rotateRev (B)
 - Cons)
called exec (forced -
called rev
called concat
called drop
called rotateRev (B)
 - Cons)
called tail
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
called rev
called concat
called drop
called rotateRev (A)
called rev
called concat
 - Cons)
called exec (forced -
 - Cons)
called tail
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called tail
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called tail
called exec (forced -
 - Cons)
called exec (forced -
 - Nil)
called exec (forced -
 - Cons)
called exec (forced -
 - Cons)
called tail
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (forced -
 - Nil)
called exec (inaction - Nil)
called tail
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called tail
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called exec (inaction - Nil)
called rotateDrop j=7, c=3 ##
queue
	(7,
	SUSP,
	SUSP,
	7,
	SUSP,
	SUSP)
- : unit = ()
#   ----------------------------------------
- : unit = ()
#