mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
CCFQueue is now a functional double-ended queue
This commit is contained in:
Simon Cruanes
parent
696d1f27cf
commit
a87a5b0315
3 changed files with 335 additions and 78 deletions
312
core/CCFQueue.ml
312
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 = {
|
||||
hd : 'a list;
|
||||
tl : 'a list;
|
||||
} (** Queue containing elements of type 'a *)
|
||||
type 'a sequence = ('a -> unit) -> unit
|
||||
type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
|
||||
type 'a equal = 'a -> 'a -> bool
|
||||
|
||||
let empty = {
|
||||
hd = [];
|
||||
tl = [];
|
||||
}
|
||||
(** {2 Basics} *)
|
||||
|
||||
(* invariant: if hd=[], then tl=[] *)
|
||||
let _make hd tl = match hd with
|
||||
| [] -> {hd=List.rev tl; tl=[] }
|
||||
| _::_ -> {hd; tl; }
|
||||
type 'a digit =
|
||||
| Zero
|
||||
| One of 'a
|
||||
| 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 =
|
||||
match q.hd with
|
||||
| [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek")
|
||||
| x::_ -> x
|
||||
let _single x = Shallow (One x)
|
||||
let _double x y = Shallow (Two (x,y))
|
||||
let _deep hd middle tl =
|
||||
assert (hd<>Zero && tl<>Zero);
|
||||
Deep (hd, middle, tl)
|
||||
|
||||
let peek q = match q.hd with
|
||||
| [] -> None
|
||||
| x::_ -> Some x
|
||||
let is_empty = function
|
||||
| Shallow Zero -> true
|
||||
| _ -> false
|
||||
|
||||
let pop_exn q =
|
||||
match q.hd with
|
||||
| [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek")
|
||||
| x::hd' ->
|
||||
let q' = _make hd' q.tl in
|
||||
x, q'
|
||||
let _empty = Lazy.from_val empty
|
||||
|
||||
let pop q =
|
||||
try Some (pop_exn q)
|
||||
with Invalid_argument _ -> None
|
||||
let rec cons : 'a. 'a -> 'a t -> 'a t
|
||||
= fun x q -> match q with
|
||||
| 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 =
|
||||
try
|
||||
let _, q' = pop_exn q in
|
||||
q'
|
||||
with Invalid_argument _ -> q
|
||||
let rec snoc : 'a. 'a t -> 'a -> 'a t
|
||||
= fun q x -> match q with
|
||||
| Shallow Zero -> _single x
|
||||
| Shallow (One y) -> Shallow (Two (y,x))
|
||||
| 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;
|
||||
tl=q2.tl @ (List.rev_append q2.hd q1.tl);
|
||||
}
|
||||
match q1, q2 with
|
||||
| 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 acc' = List.fold_left f acc q.hd in
|
||||
List.fold_right (fun x acc -> f acc x) q.tl acc'
|
||||
let _fold_digit f acc d = match d with
|
||||
| Zero -> 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 q = ref empty in
|
||||
seq (fun x -> q := push x !q);
|
||||
!q
|
||||
let to_list q =
|
||||
let l = ref [] in
|
||||
to_seq q (fun x -> l := x :: !l);
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(** Push element at the end of the queue *)
|
||||
exception Empty
|
||||
|
||||
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
|
||||
(** 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
|
||||
val take_front : 'a t -> ('a * 'a t) option
|
||||
(** Get and remove the first element *)
|
||||
|
||||
val pop_exn : 'a t -> ('a * 'a t)
|
||||
(** Same as {!pop}, but fails on empty queues.
|
||||
@raise Invalid_argument if the queue is empty *)
|
||||
val take_front_exn : 'a t -> ('a * 'a t)
|
||||
(** Same as {!take_front}, but fails on empty queues.
|
||||
@raise Empty if the queue is empty *)
|
||||
|
||||
val junk : 'a t -> 'a t
|
||||
(** Remove first element. If the queue is empty, do nothing. *)
|
||||
val take_front_l : int -> 'a t -> 'a list * 'a t
|
||||
(** [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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 x, q = FQueue.pop_exn q in
|
||||
let q = FQueue.of_list [1;2;3;4] 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);
|
||||
let x, q = FQueue.pop_exn q in
|
||||
OUnit.assert_equal 2 (FQueue.first_exn q);
|
||||
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;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue