Skip to content

Instantly share code, notes, and snippets.

@yuga

yuga/realTimeDeque.ml

Created August 6, 2012 05:25
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save yuga/3271021 to your computer and use it in GitHub Desktop.
Save yuga/3271021 to your computer and use it in GitHub Desktop.
Download ZIP
An implementation of Real-Time Deques in PFDS (Chapter 8.4.3)
Raw
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";;
Raw
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 = ()
#
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment