CCFQueue is now a functional double-ended queue

core/CCFQueue.ml

@@ -25,77 +25,283 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Functional queues (fifo)} *)
 
-type 'a t = {
+type 'a sequence = ('a -> unit) -> unit
-  hd : 'a list;
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
-  tl : 'a list;
+type 'a equal = 'a -> 'a -> bool
-} (** Queue containing elements of type 'a *)
 
-let empty = {
+(** {2 Basics} *)
-  hd = [];
-  tl = [];
-}
 
-(* invariant: if hd=[], then tl=[] *)
+type 'a digit =
-let _make hd tl = match hd with
+  | Zero
-  | [] -> {hd=List.rev tl; tl=[] }
+  | One of 'a
-  | _::_ -> {hd; tl; }
+  | Two of 'a * 'a
+  | Three of 'a * 'a * 'a
 
-let is_empty q = q.hd = []
+type 'a t =
+  | Shallow of 'a digit
+  | Deep of 'a digit * ('a * 'a) t lazy_t * 'a digit
 
-let push x q = {q with tl = x :: q.tl; }
+let empty = Shallow Zero
 
-let snoc q x = push x q
+exception Empty
 
-let peek_exn q =
+let _single x = Shallow (One x)
-  match q.hd with
+let _double x y = Shallow (Two (x,y))
-  | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek")
+let _deep hd middle tl =
-  | x::_ -> x
+  assert (hd<>Zero && tl<>Zero);
+  Deep (hd, middle, tl)
 
-let peek q = match q.hd with
+let is_empty = function
-  | [] -> None
+  | Shallow Zero -> true
-  | x::_ -> Some x
+  | _ -> false
 
-let pop_exn q =
+let _empty = Lazy.from_val empty
-  match q.hd with
-  | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek")
-  | x::hd' ->
-    let q' = _make hd' q.tl in
-    x, q'
 
-let pop q =
+let rec cons : 'a. 'a -> 'a t -> 'a t
-  try Some (pop_exn q)
+  = fun x q -> match q with
-  with Invalid_argument _ -> None
+  | Shallow Zero -> _single x
+  | Shallow (One y) -> Shallow (Two (x,y))
+  | Shallow (Two (y,z)) -> Shallow (Three (x,y,z))
+  | Shallow (Three (y,z,z')) ->
+      _deep (Two (x,y)) _empty (Two (z,z'))
+  | Deep (Zero, middle, tl) -> assert false
+  | Deep (One y, middle, tl) -> _deep (Two (x,y)) middle tl
+  | Deep (Two (y,z), middle, tl) -> _deep (Three (x,y,z)) middle tl
+  | Deep (Three (y,z,z'), lazy q', tail) ->
+      _deep (Two (x,y)) (lazy (cons (z,z') q')) tail
 
-let junk q =
+let rec snoc : 'a. 'a t -> 'a -> 'a t
-  try
+  = fun q x -> match q with
-    let _, q' = pop_exn q in
+  | Shallow Zero -> _single x
-    q'
+  | Shallow (One y) -> Shallow (Two (y,x))
-  with Invalid_argument _ -> q
+  | Shallow (Two (y,z)) -> Shallow (Three (y,z,x))
+  | Shallow (Three (y,z,z')) ->
+      _deep (Two (y,z)) _empty (Two (z',x))
+  | Deep (hd, middle, Zero) -> assert false
+  | Deep (hd, middle, One y) -> _deep hd middle (Two(y,x))
+  | Deep (hd, middle, Two (y,z)) -> _deep hd middle (Three(y,z,x))
+  | Deep (hd, lazy q', Three (y,z,z')) ->
+      _deep hd (lazy (snoc q' (y,z))) (Two(z',x))
+
+let rec take_front_exn : 'a. 'a t -> ('a *'a t)
+  = fun q -> match q with
+  | Shallow Zero -> raise Empty
+  | Shallow (One x) -> x, empty
+  | Shallow (Two (x,y)) -> x, Shallow (One y)
+  | Shallow (Three (x,y,z)) -> x, Shallow (Two (y,z))
+  | Deep (Zero, _, _) -> assert false
+  | Deep (One x, lazy q', tail) ->
+      if is_empty q'
+        then x, Shallow tail
+        else
+          let (y,z), q' = take_front_exn q' in
+          x, _deep (Two (y,z)) (Lazy.from_val q') tail
+  | Deep (Two (x,y), middle, tail) ->
+      x, _deep (One y) middle tail
+  | Deep (Three (x,y,z), middle, tail) ->
+      x, _deep (Two(y,z)) middle tail
+
+let take_front q =
+  try Some (take_front_exn q)
+  with Empty -> None
+
+let take_front_l n q =
+  let rec aux acc q n =
+    if n=0 || is_empty q then List.rev acc, q
+    else
+      let x,q' = take_front_exn q in
+      aux (x::acc) q' (n-1)
+  in aux [] q n
+
+let take_front_while p q =
+  let rec aux acc q =
+    if is_empty q then List.rev acc, q
+    else
+      let x,q' = take_front_exn q in
+      if p x then aux (x::acc) q' else List.rev acc, q
+  in aux [] q
+
+let rec take_back_exn : 'a. 'a t -> 'a t * 'a
+  = fun q -> match q with
+  | Shallow Zero -> invalid_arg "FQueue.take_back_exn"
+  | Shallow (One x) -> empty, x
+  | Shallow (Two (x,y)) -> _single x, y
+  | Shallow (Three (x,y,z)) -> Shallow (Two(x,y)), z
+  | Deep (hd, middle, Zero) -> assert false
+  | Deep (hd, lazy q', One x) ->
+      if is_empty q'
+        then Shallow hd, x
+        else
+          let q'', (y,z) = take_back_exn q' in
+          _deep hd (Lazy.from_val q'') (Two (y,z)), x
+  | Deep (hd, middle, Two(x,y)) -> _deep hd middle (One x), y
+  | Deep (hd, middle, Three(x,y,z)) -> _deep hd middle (Two (x,y)), z
+
+let take_back q =
+  try Some (take_back_exn q)
+  with Empty -> None
+
+let take_back_l n q =
+  let rec aux acc q n =
+    if n=0 || is_empty q then q, acc
+    else
+      let q',x = take_back_exn q in
+      aux (x::acc) q' (n-1)
+  in aux [] q n
+
+let take_back_while p q =
+  let rec aux acc q =
+    if is_empty q then q, acc
+    else
+      let q',x = take_back_exn q in
+      if p x then aux (x::acc) q' else q, acc
+  in aux [] q
+
+(** {2 Individual extraction} *)
+
+let first q =
+  try Some (fst (take_front_exn q))
+  with Empty -> None
+
+let first_exn q = fst (take_front_exn q)
+
+let last q =
+  try Some (snd (take_back_exn q))
+  with Empty -> None
+
+let last_exn q = snd (take_back_exn q)
+
+let init q =
+  try snd (take_front_exn q)
+  with Empty -> q
+
+let tail q =
+  try fst (take_back_exn q)
+  with Empty -> q
+
+let add_seq_front seq q =
+  let q = ref q in
+  seq (fun x -> q := cons x !q);
+  !q
+
+let add_seq_back q seq =
+  let q = ref q in
+  seq (fun x -> q := snoc !q x);
+  !q
+
+let _digit_to_seq d k = match d with
+  | Zero -> ()
+  | One x -> k x
+  | Two (x,y) -> k x; k y
+  | Three (x,y,z) -> k x; k y; k z
+
+let rec to_seq : 'a. 'a t -> 'a sequence
+  = fun q k -> match q with
+  | Shallow d -> _digit_to_seq d k
+  | Deep (hd, lazy q', tail) ->
+      _digit_to_seq hd k;
+      to_seq q' (fun (x,y) -> k x; k y);
+      _digit_to_seq tail k
 
-(** Append two queues. Elements from the second one come
-    after elements of the first one *)
 let append q1 q2 =
-  { hd=q1.hd;
+  match q1, q2 with
-    tl=q2.tl @ (List.rev_append q2.hd q1.tl);
+  | Shallow Zero, _ -> q2
-  }
+  | _, Shallow Zero -> q1
+  | _ -> add_seq_front (to_seq q1) q2
 
-let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; }
+let _map_digit f d = match d with
+  | Zero -> Zero
+  | One x -> One (f x)
+  | Two (x,y) -> Two (f x, f y)
+  | Three (x,y,z) -> Three (f x, f y, f z)
 
-let size q = List.length q.hd + List.length q.tl
+let rec map : 'a 'b. ('a -> 'b) -> 'a t -> 'b t
+  = fun f q -> match q with
+  | Shallow d -> Shallow (_map_digit f d)
+  | Deep (hd, lazy q', tl) ->
+      let q'' = map (fun (x,y) -> f x, f y) q' in
+      _deep (_map_digit f hd) (Lazy.from_val q'') (_map_digit f tl)
+
+let _size_digit = function
+  | Zero -> 0
+  | One _ -> 1
+  | Two _ -> 2
+  | Three _ -> 3
+
+let rec size : 'a. 'a t -> int
+  = function
+  | Shallow d -> _size_digit d
+  | Deep (hd, lazy q', tl) ->
+      _size_digit hd + 2 * size q' + _size_digit tl
 
 let (>|=) q f = map f q
 
-let fold f acc q =
+let _fold_digit f acc d = match d with
-  let acc' = List.fold_left f acc q.hd in
+  | Zero -> acc
-  List.fold_right (fun x acc -> f acc x) q.tl acc'
+  | One x -> f acc x
+  | Two (x,y) -> f (f acc x) y
+  | Three (x,y,z) -> f (f (f acc x) y) z
 
-let iter f q = fold (fun () x -> f x) () q
+let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+  = fun f acc q -> match q with
+  | Shallow d -> _fold_digit f acc d
+  | Deep (hd, lazy q', tl) ->
+      let acc = _fold_digit f acc hd in
+      let acc = fold (fun acc (x,y) -> f (f acc x) y) acc q' in
+      _fold_digit f acc tl
 
-type 'a sequence = ('a -> unit) -> unit
+let iter f q = to_seq q f
 
-let to_seq q = fun k -> iter k q
+let of_list l = List.fold_left snoc empty l
 
-let of_seq seq =
+let to_list q =
-  let q = ref empty in
+  let l = ref [] in
-  seq (fun x -> q := push x !q);
+  to_seq q (fun x -> l := x :: !l);
-  !q
+  List.rev !l
+
+let of_seq seq = add_seq_front seq empty
+
+let _nil () = `Nil
+let _single x cont () = `Cons (x, cont)
+let _double x y cont () = `Cons (x, _single y cont)
+let _triple x y z cont () = `Cons (x, _double y z cont)
+
+let _digit_to_klist d cont = match d with
+  | Zero -> _nil
+  | One x -> _single x cont
+  | Two (x,y) -> _double x y cont
+  | Three (x,y,z) -> _triple x y z cont
+
+let rec _flat_klist : 'a. ('a * 'a) klist -> 'a klist -> 'a klist
+  = fun l cont () -> match l () with
+  | `Nil -> cont ()
+  | `Cons ((x,y),l') -> _double x y (_flat_klist l' cont) ()
+
+let to_klist q =
+  let rec aux : 'a. 'a t -> 'a klist -> 'a klist
+    = fun q cont () -> match q with
+    | Shallow d -> _digit_to_klist d cont ()
+    | Deep (hd, lazy q', tl) ->
+        _digit_to_klist hd
+          (_flat_klist
+            (aux q' _nil)
+            (_digit_to_klist tl cont))
+          ()
+  in
+  aux q _nil
+
+let of_klist l =
+  let rec seq l k = match l() with
+    | `Nil -> ()
+    | `Cons(x,l') -> k x; seq l' k
+  in
+  add_seq_front (seq l) empty
+
+let rec _equal_klist eq l1 l2 = match l1(), l2() with
+  | `Nil, `Nil -> true
+  | `Nil, _
+  | _, `Nil -> false
+  | `Cons(x1,l1'), `Cons(x2,l2') ->
+      eq x1 x2 && _equal_klist eq l1' l2'
+
+let equal eq q1 q2 = _equal_klist eq (to_klist q1) (to_klist q2)

core/CCFQueue.mli

@@ -23,7 +23,13 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)
 
-(** {1 Functional queues (fifo)} *)
+(** {1 Functional queues} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a equal = 'a -> 'a -> bool
+
+(** {2 Basics} *)
 
 type +'a t
   (** Queue containing elements of type 'a *)
@@ -32,28 +38,61 @@ val empty : 'a t
 
 val is_empty : 'a t -> bool
 
-val push : 'a -> 'a t -> 'a t
+exception Empty
-(** Push element at the end of the queue *)
+
+val cons : 'a -> 'a t -> 'a t
+(** Push element at the front of the queue *)
 
 val snoc : 'a t -> 'a -> 'a t
-(** Flip version of {!push} *)
+(** Push element at the end of the queue *)
 
-val peek : 'a t -> 'a option
+val take_front : 'a t -> ('a * 'a t) option
-(** First element of the queue *)
-
-val peek_exn : 'a t -> 'a
-(** Same as {!peek} but
-    @raise Invalid_argument if the queue is empty *)
-
-val pop : 'a t -> ('a * 'a t) option
 (** Get and remove the first element *)
 
-val pop_exn : 'a t -> ('a * 'a t)
+val take_front_exn : 'a t -> ('a * 'a t)
-(** Same as {!pop}, but fails on empty queues.
+(** Same as {!take_front}, but fails on empty queues.
-    @raise Invalid_argument if the queue is empty *)
+    @raise Empty if the queue is empty *)
 
-val junk : 'a t -> 'a t
+val take_front_l : int -> 'a t -> 'a list * 'a t
-  (** Remove first element. If the queue is empty, do nothing. *)
+(** [take_front_l n q] takes at most [n] elements from the front
+    of [q], and returns them wrapped in a list *)
+
+val take_front_while : ('a -> bool) -> 'a t -> 'a list * 'a t
+
+val take_back : 'a t -> ('a t * 'a) option
+(** Take last element *)
+
+val take_back_exn : 'a t -> ('a t * 'a)
+
+val take_back_l : int -> 'a t -> 'a t * 'a list
+(** [take_back_l n q] removes and returns the last [n] elements of [q]. The
+    elements are in the order of the queue, that is, the head of the returned
+    list is the first element to appear via {!take_front}.
+    [take_back_l 2 (of_list [1;2;3;4]) = of_list [1;2], [3;4]] *)
+
+val take_back_while : ('a -> bool) -> 'a t -> 'a t * 'a list
+
+(** {2 Individual extraction} *)
+
+val first : 'a t -> 'a option
+(** First element of the queue *)
+
+val last : 'a t -> 'a option
+(** Last element of the queue *)
+
+val first_exn : 'a t -> 'a
+(** Same as {!peek} but
+    @raise Empty if the queue is empty *)
+
+val last_exn : 'a t -> 'a
+
+val tail : 'a t -> 'a t
+(** Queue deprived of its first element. Does nothing on empty queues *)
+
+val init : 'a t -> 'a t
+(** Queue deprived of its last element. Does nothing on empty queues *)
+
+(** {2 Global Operations} *)
 
 val append : 'a t -> 'a t -> 'a t
   (** Append two queues. Elements from the second one come
@@ -66,13 +105,25 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 val (>|=) : 'a t -> ('a -> 'b) -> 'b t
 
 val size : 'a t -> int
-  (** Number of elements in the queue (linear in time) *)
+(** Number of elements in the queue (linear in time) *)
 
 val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
 
 val iter : ('a -> unit) -> 'a t -> unit
 
-type 'a sequence = ('a -> unit) -> unit
+val equal : 'a equal -> 'a t equal
+
+(** {2 Conversions} *)
+
+val of_list : 'a list -> 'a t
+val to_list : 'a t -> 'a list
+
+val add_seq_front : 'a sequence -> 'a t -> 'a t
+val add_seq_back : 'a t -> 'a sequence -> 'a t
+
 val to_seq : 'a t -> 'a sequence
 val of_seq : 'a sequence -> 'a t
 
+val to_klist : 'a t -> 'a klist
+val of_klist : 'a klist -> 'a t
+

tests/test_fQueue.ml

@@ -10,18 +10,18 @@ let test_empty () =
 
 let test_push () =
   let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in
-  let q = FQueue.junk q in
+  let q = FQueue.tail q in
   let q = List.fold_left FQueue.snoc q [6;7;8] in
   let l = Sequence.to_list (FQueue.to_seq q) in
   OUnit.assert_equal [2;3;4;5;6;7;8] l
 
 let test_pop () =
-  let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in
+  let q = FQueue.of_list [1;2;3;4] in
-  let x, q = FQueue.pop_exn q in
+  let x, q = FQueue.take_front_exn q in
   OUnit.assert_equal 1 x;
   let q = List.fold_left FQueue.snoc q [5;6;7] in
-  OUnit.assert_equal 2 (FQueue.peek_exn q);
+  OUnit.assert_equal 2 (FQueue.first_exn q);
-  let x, q = FQueue.pop_exn q in
+  let x, q = FQueue.take_front_exn q in
   OUnit.assert_equal 2 x;
   ()
 
@@ -39,7 +39,7 @@ let test_fold () =
   ()
 
 let suite =
-  "test_pQueue" >:::
+  "test_FQueue" >:::
     [ "test_empty" >:: test_empty;
       "test_push" >:: test_push;
       "test_pop" >:: test_pop;