(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_deque.ml

  Copyright (c) 2003-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, 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. 
 *---------------------------------------------------------------------------*)

(* A brief note about the algorithm in this module.

    This algorithm is an original invention, but it owes a few of its key
    insights to various algorithms published by Kaplan, Okasaki and Tarjan.
    
    While the algorithm here is not strictly a *pure* functional deque--
    since it uses lazy evaluation in one place to amortize the cost of
    concatenation across calls to the pop function-- the inventor makes the
    baseless claim that it is substantially more efficient and simpler than
    other algorithms with similar complexity.  The claim is baseless because
    benchmarks and evaluation criteria have not been made to compare this
    algorithm formally with published algorithms.  However, informal testing by
    the inventor strongly suggests that the claim merits further investigation.
    
    The inventor invites other scientists to collaborate in the development of
    a scholarly paper about this algorithm and its performance characteristics.
    
                                            --j h woodyatt <jhw@conjury.org>
*)

type 'a t =
    | Z
    (* An empty deque *)
    
    | Y of 'a
    (* A deque containing one element. *)
    
    | X of 'a * 'a
    (*
        An internal node of a deque that contains two elements.  Nodes of this
        variant constructor are only allowed to be the left or right subnode of
        a U node (see below) that is itself a middle subnode of a U node that
        does not have an X subnode in the corresponding position.
    *)
    
    | U of 'a t * ('a * 'a) t * 'a t
    (*
        A deque, or an internal node of a deque that contains three subnodes:
        1) a left node of single elements; 2) a middle node of element pairs;
        and 3) a right node of single elements.   The middle subnode is never
        a Z, X or V node.  The other subnodes are never U or V nodes.
    *)
    
    | V of 'a t * 'a t t Lazy.t * 'a t
    (*
        A deque composed by catenation.  It contains three subnodes: 1) a left
        deque; 2) a lazy evaluation of a deque of deques, i.e. the suspension
        of the remaining results of catenation; and 3) a right deque.  The
        left and right subnodes are never empty deques, and they are never
        V nodes themselves.
    *)

(*
    An invariant rule is applied to the tree structure in order to obtain the
    recursive slowdown effect necessary to achieve O(1) asymptotic complexity
    in all the operations.  The rule amounts to a requirement on the left and
    right subnodes in a stack of U nodes that may be mapped as digits in a
    redundant binary representation, i.e. Z, Y, and X nodes correspond to 0,
    1 and 2 digits respectively.
    
    In redundant binary representation, a number is represented with the 0, 1
    and 2 digits, with the rule demanding that when scanning the digits from
    most significant to least significant we always find at least one 0 digit
    after every 2 digit.
    
    The key insight to apply this invariant to the tree structure of a
    persistent functional deque comes from Kaplan and Tarjan [insert citation
    here].
*)

let nil = Z
let empty = function Z -> true | _ -> false

module type Direction_T = sig
    val push: 'a -> 'a t -> 'a t
    val pop: 'a t -> ('a * 'a t) option
    val head: 'a t -> 'a
    val tail: 'a t -> 'a t
    val fold: ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
    val of_list: 'a list -> 'a t
    val of_seq: 'a Cf_seq.t -> 'a t
    val to_list: 'a t -> 'a list
    val to_seq: 'a t -> 'a Cf_seq.t
    val to_seq2: 'a t -> ('a * 'a t) Cf_seq.t
end

module rec A: Direction_T = struct

    let rec push x = function
        | V (a, b, c) ->
            V (push x a, b, c)
        | U (Z, a, b) ->
            (* _0,_ -=> _1,_ *)
            U (Y x, a, b)
        | U (Y a, b, y0) ->
            begin
                match b with
                | Y (b,c) ->
                    begin
                        match y0 with
                        | Z -> U (Y x, Y (a,b), Y c)
                        | Y d -> U (Y x, U (Z, Y ((a,b),(c,d)), Z), Z)
                        | _ -> assert (not true); Z
                    end
                | U (Y (b,c), Y ((d,e),(f,g)), Y (h,i)) when y0 = Z ->
                    U (Y x, U (Y (a,b), Y ((c,d),(e,f)), Y (g,h)), Y i)
                | U (b, c, d) ->
                    let y1 =
                        match b with
                        | X (b1,b2) ->
                            U (Y (x,a), A.push (b1,b2) c, d)
                        | Y b ->
                            begin
                                match c, d with
                                | Y (c,d), Z -> U (Y (x,a), Y (b,c), Y d)
                                | _, _ -> U (X ((x,a),b), c, d)
                            end
                        | Z ->
                            U (Y (x,a), c, d)
                        | _ ->
                            assert (not true);
                            Z
                    in
                    U (Z, y1, y0)
                | _ ->
                    assert (not true);
                    Z
            end
        | Y a ->
            U (Z, Y (x,a), Z)
        | y ->
            assert (y = Z);
            Y x
    and pop = function
        | V (a, b, c) ->
             begin
                match pop a with
                | None ->
                    assert (not true);
                    None
                | Some (x, Z) ->
                    let y =
                        match A.pop (Lazy.force b) with
                        | Some (y, b) -> V (y, Lazy.lazy_from_val b, c)
                        | None -> c
                    in
                    Some (x, y)
                | Some (x, a) ->
                    Some (x, V (a, b, c))
             end            
        | U (Y x, a, b) ->
            let y =
                match a, b with
                | Y (a,b), X (c,d) -> U (Y a, Y (b,c), Y d)
                | _, _ -> U (Z, a, b)
            in
            Some (x, y)
        | U (Z, a, b) ->
            begin
                match a, b with
                | Y (x,a), b ->
                    let y =
                        match b with
                        | X (b,c) -> U (Y a, Y (b,c), Z)
                        | Y b -> U (Z, Y (a,b), Z)
                        | Z -> Y a
                        | _ -> assert (not true); Z
                    in
                    Some (x, y)
                | U (a, y2, y1), y0 ->
                    begin
                        match a with
                        | X ((x,a),b) ->
                            Some (x, U (Y a, U (Y b, y2, y1), y0))
                        | Y (x,a) ->
                            let y =
                                match y2, y1 with
                                | Y (b,c), X (d,e) -> U (Y b, Y (c,d), Y e)
                                | Y _, _ -> U (Z, y2, y1)
                                | U _, _ ->
                                    let (hd1,hd2), tl =
                                        match A.pop y2 with
                                        | Some (hd, tl) -> hd, tl
                                        | None -> assert false
                                    in
                                    U (X (hd1,hd2), tl, y1)
                                | _, _ ->
                                    assert (not true);
                                    Z
                            in
                            Some (x, U (Y a, y, y0))
                        | Z ->
                            let x, a, b =
                                match y2 with
                                | Y ((x,a),b) -> x, a, b
                                | _ -> assert false
                            in
                            let y =
                                match y1, y0 with
                                | X (c,d), Y _ -> U (Z, Y (b,c), Y d)
                                | Y c, _ -> U (Z, Y (b,c), Z)
                                | Z, _ -> Y b
                                | _, _ -> assert (not true); Z
                            in
                            Some (x, U (Y a, y, y0))
                        | _ ->
                            assert (not true);
                            None
                    end

                | _, _ ->
                    assert (not true);
                    None
            end
        | Y x ->
            Some (x, Z)
        | y ->
            assert (y = Z);
            None

    let rec head = function
        | Y x
        | U (Y x, _, _)
        | U (Z, Y (x, _), _)
        | U (Z, U (Y (x, _), _, _), _)
        | U (Z, U (X ((x, _), _), _, _), _)
        | U (Z, U (Z, Y ((x, _), _), _), _) ->
            x
        | V (a, _, _) ->
            head a
        | y ->
            assert (y = Z);
            raise Not_found
    
    let tail d = match pop d with Some (_, d) -> d | None -> Z
    
    let rec fold f v = function
        | Z -> v
        | Y a -> f v a
        | X (a,b) -> f (f v a) b
        | U (a,b,c) ->
            let v = fold f v a in
            let g v (x, y) = f (f v x) y in
            let v = A.fold g v b in
            fold f v c
        | V (a,b,c) ->
            let v = fold f v a in
            let v = A.fold (fold f) v (Lazy.force b) in
            fold f v c
    
    let of_list s = List.fold_left (fun q a -> B.push a q) nil s
    let of_seq z = Cf_seq.fold (fun q a -> B.push a q) nil z
    let to_list d = B.fold (fun s a -> a :: s) [] d

    let rec to_seq d =
        lazy begin
            match pop d with
            | Some (hd, tl) -> Cf_seq.P (hd, to_seq tl)
            | None -> Cf_seq.Z
        end
    
    let rec to_seq2 d =
        lazy begin
            match pop d with
            | Some (hd, tl) -> Cf_seq.P ((hd, tl), to_seq2 tl)
            | None -> Cf_seq.Z
        end
end

and B: Direction_T = struct

    let rec push x = function
        | V (a, b, c) ->
            V (a, b, push x c)
        | U (a, b, Z) ->
            U (a, b, Y x)
        | U (y0, b, Y a) ->
            begin
                match b with
                | Y (c,b) ->
                    begin
                        match y0 with
                        | Z -> U (Y c, Y (b,a), Y x)
                        | Y d -> U (Z, U (Z, Y ((d,c),(b,a)), Z), Y x)
                        | _ -> assert (not true); Z
                    end
                | U (Y (i,h), Y ((g,f),(e,d)), Y (c,b)) when y0 = Z ->
                    U (Y i, U (Y (h,g), Y ((f,e),(d,c)), Y (b,a)), Y x)
                | U (d, c, b) ->
                    let y1 =
                        match b with
                        | X (b1,b2) ->
                            U (d, B.push (b1,b2) c, Y (a,x))
                        | Y b ->
                            begin
                                match d, c with
                                | Z, Y (d,c) -> U (Y d, Y (c,b), Y (a,x))
                                | _, _ -> U (d, c, X (b,(a,x)))
                            end
                        | Z ->
                            U (d, c, Y (a,x))
                        | _ ->
                            assert (not true);
                            Z
                    in
                    U (y0, y1, Z)
                | _ ->
                    assert (not true);
                    Z
            end
        | Y a ->
            U (Z, Y (a,x), Z)
        | Z ->
            Y x
        | _ ->
            assert (not true);
            Z

    
    and pop = function
        | V (c, b, a) ->
             begin
                match pop a with
                | None ->
                    assert (not true);
                    None
                | Some (x, Z) ->
                    let y =
                        match B.pop (Lazy.force b) with
                        | Some (y, b) -> V (c, Lazy.lazy_from_val b, y)
                        | None -> c
                    in
                    Some (x, y)
                | Some (x, a) ->
                    Some (x, V (c, b, a))
             end
        | U (b, a, Y x) ->
            let y =
                match b, a with
                | X (d,c), Y (b,a) -> U (Y d, Y (c,b), Y a)
                | _, _ -> U (b, a, Z)
            in
            Some (x, y)
        | U (b, a, Z) ->
            begin
                match b, a with
                | b, Y (a,x) ->
                    let y =
                        match b with
                        | X (c,b) -> U (Z, Y (c,b), Y a)
                        | Y b -> U (Z, Y (b,a), Z)
                        | Z -> Y a
                        | _ -> assert (not true); Z
                    in
                    Some (x, y)
                | y0, U (y1, y2, a) ->
                    begin
                        match a with
                        | X (b,(a,x)) ->
                            Some (x, U (y0, U (y1, y2, Y b), Y a))
                        | Y (a,x) ->
                            let y =
                                match y1, y2 with
                                | X (e,d), Y (c,b) -> U (Y e, Y (d,c), Y b)
                                | _, Y _ -> U (y1, y2, Z)
                                | _, U _ ->
                                    let (hd1,hd2), tl =
                                        match B.pop y2 with
                                        | Some (hd, tl) -> hd, tl
                                        | None -> assert false
                                    in
                                    U (y1, tl, X (hd1,hd2))
                                | _, _ ->
                                    assert (not true);
                                    Z
                            in
                            Some (x, U (y0, y, Y a))
                        | Z ->
                            let b, a, x =
                                match y2 with
                                | Y (b,(a,x)) -> b, a, x
                                | _ -> assert false
                            in
                            let y =
                                match y0, y1 with
                                | Y _, X (d,c) -> U (Y d, Y (c,b), Z)
                                | _, Y c -> U (Z, Y (c,b), Z)
                                | _, Z -> Y b
                                | _, _ -> assert (not true); Z
                            in
                            Some (x, U (y0, y, Y a))
                        | _ ->
                            assert (not true);
                            None
                    end

                | _, _ ->
                    assert (not true);
                    None
            end
        | X (a,x) ->
            Some (x, Y a)
        | Y x ->
            Some (x, Z)
        | y ->
            assert (y = Z);
            None

    let rec head = function
        | Y x
        | U (_, _, Y x)
        | U (_, Y (_, x), Z)
        | U (_, U (_, _, Y (_, x)), Z)
        | U (_, U (_, _, X (_, (_, x))), Z)
        | U (_, U (_, Y (_, (_, x)), Z), Z) ->
            x
        | V (_, _, a) ->
            head a
        | y ->
            assert (y = Z);
            raise Not_found

    let tail d = match pop d with Some (_, d) -> d | None -> Z
    
    let rec fold f v = function
        | Z -> v
        | Y a -> f v a
        | X (a,b) -> f (f v b) a
        | U (a,b,c) ->
            let v = fold f v c in
            let g v (x, y) = f (f v y) x in
            let v = B.fold g v b in
            fold f v a
        | V (a,b,c) ->
            let v = fold f v c in
            let v = B.fold (fold f) v (Lazy.force b) in
            fold f v a
    
    let of_list s = List.fold_left (fun q a -> A.push a q) nil s
    let of_seq z = Cf_seq.fold (fun q a -> A.push a q) nil z
    let to_list d = A.fold (fun s a -> a :: s) [] d

    let rec to_seq d =
        lazy begin
            match pop d with
            | Some (hd, tl) -> Cf_seq.P (hd, to_seq tl)
            | None -> Cf_seq.Z
        end
    
    let rec to_seq2 d =
        lazy begin
            match pop d with
            | Some (hd, tl) -> Cf_seq.P ((hd, tl), to_seq2 tl)
            | None -> Cf_seq.Z
        end
end

module type Iterators_T = sig
    val iterate: ('a -> unit) -> 'a t -> unit
    val predicate: ('a -> bool) -> 'a t -> bool
    val filter: ('a -> bool) -> 'a t -> 'a t
    val map: ('a -> 'b) -> 'a t -> 'b t
    val optmap: ('a -> 'b option) -> 'a t -> 'b t
    val listmap: ('a -> 'b list) -> 'a t -> 'b t
    val seqmap: ('a -> 'b Cf_seq.t) -> 'a t -> 'b t
    val partition: ('a -> bool) -> 'a t -> 'a t * 'a t
    val length: 'a t -> int
    val catenate: 'a t -> 'a t -> 'a t
end

module rec I: Iterators_T = struct
    let rec iterate f = function
        | Z -> ()
        | Y a -> f a
        | X (a,b) -> f a; f b
        | U (a,b,c) ->
            iterate f a;
            I.iterate (fun (x,y) -> f x; f y) b;
            iterate f c
        | V (a,b,c) ->
            iterate f a;
            I.iterate (iterate f) (Lazy.force b);
            iterate f c

    let rec predicate f = function
        | Z -> true
        | Y a -> f a
        | X (a,b) -> f a && f b
        | U (a,b,c) ->
            predicate f a &&
            I.predicate (fun (x,y) -> f x && f y) b &&
            predicate f c
        | V (a,b,c) ->
            predicate f a &&
            I.predicate (predicate f) (Lazy.force b) &&
            predicate f c

    let filter f =
        let g d' x = if f x then B.push x d' else d' in
        A.fold g Z

    let rec map f = function
        | Z ->
            Z
        | Y a ->
            Y (f a)
        | X (a,b) ->
            X (f a, f b)
        | U (a,b,c) ->
            let a = map f a in
            let b = I.map (fun (x,y) -> f x, f y) b in
            let c = map f c in
            U (a, b, c)
        | V (a,b,c) ->
            let a = map f a in
            let b = Lazy.lazy_from_val (I.map (map f) (Lazy.force b)) in
            let c = map f c in
            V (a, b, c)

    let optmap f =
        let g d' x = match f x with Some y -> B.push y d' | None -> d' in
        fun d -> Cf_seq.fold g Z (A.to_seq d)

    let listmap f =
        let g d' x = List.fold_left (fun d x -> B.push x d) d' (f x) in
        fun d -> Cf_seq.fold g Z (A.to_seq d)

    let seqmap f =
        let g d' x = Cf_seq.fold (fun d x -> B.push x d) d' (f x) in
        fun d -> Cf_seq.fold g Z (A.to_seq d)

    let partition f =
        let g (d0, d1) x = if f x then B.push x d0, d1 else d0, B.push x d1 in
        fun d -> Cf_seq.fold g (Z, Z) (A.to_seq d)

    (** @param d A deque *)
    let rec length = function
        | Z -> 0
        | Y _ -> 1
        | X _ -> 2
        | U (a,b,c) -> length a + length c + (2 * I.length b)
        | V (a,b,c) ->
            length a + length c +
            A.fold (fun n d -> n + length d) 0 (Lazy.force b)

    let rec catenate q1 q2 =
        match q1, q2 with
        | (Z, q | q, Z) -> q
        | Y a, x -> A.push a x
        | x, Y b -> B.push b x
        | (U _ as a), (U _ as b) ->
            V (a, Lazy.lazy_from_val Z, b)
        | (U _ as a), V (b, c, d) ->
            V (a, Lazy.lazy_from_val (A.push b (Lazy.force c)), d)
        | V (a, b, c), (U _ as d) ->
            V (a, Lazy.lazy_from_val (B.push c (Lazy.force b)), d)
        | V (a, b, c), V (d, e, f) ->
            let q1 = B.push c (Lazy.force b) and q2 = A.push d (Lazy.force e) in
            V (a, lazy (I.catenate q1 q2), f)
        | _, _ ->
            assert (not true); Z
end

include I

(*
let rec sprint f = function
    | Z ->
        Printf.sprintf "%c" '-'
    | Y a ->
        Printf.sprintf "%s" (f a)
    | X (a, b) ->
        Printf.sprintf "%s,%s" (f a) (f b)
    | U (a, b, c) ->
        let a = sprint f a in
        let b = (Obj.magic sprint) (fun (x1,x2) ->
            let x = sprint f (X (x1,x2)) in
            Printf.sprintf "(%s)" x
        ) b in
        let c = sprint f c in
        Printf.sprintf "[%s|%s|%s]" a b c

    | V (a, b, c) ->
        let a = sprint f a in
        let b =
            let g x = Printf.sprintf "<%s>" (sprint f x) in
            (Obj.magic sprint) g (Lazy.force b)
        in
        let c = sprint f c in
        Printf.sprintf "{%s;%s;%s}" a b c
*)

(*--- End of File [ cf_deque.ml ] ---*)
