open SequenceSig  (* "require" rather than "open" *)
open NullPointers (* "require" rather than "open" *)


(*-----------------------------------------------------------------------------*)

module Make (Chunk : SequenceSig.FixedCapacityS) =
struct


(*-----------------------------------------------------------------------------*)

(** Representation 
    -- filling outer buffers before inner buffers, unlike in the paper;
    -- a level is shallow iff the middle pointer is null; in this case:
         - all the data gets stored in the front_outer buffer,
         - the back_outer pointer is equal to the front_outer pointer, 
         - both inner buffers are null. *)

type 'a t = {
  mutable front_outer : 'a Chunk.t;
  mutable front_inner : 'a Chunk.t;
  mutable middle : ('a Chunk.t) t;  
  mutable back_inner : 'a Chunk.t;
  mutable back_outer : 'a Chunk.t; }


(*-----------------------------------------------------------------------------*)

(** Creation of an empty structure 
    (for representing the middle sequence of a shallow level) *)    

let empty : 'a. unit -> ('a Chunk.t) t = fun () ->
  NullPointers.null

(** Test if level is shallow *)    

let is_shallow s =
   s.middle == empty()

(** Creation *)

let create () = 
  let c = Chunk.create() in
  { front_outer = c;
    front_inner = Chunk.null;
    middle = empty();
    back_inner = Chunk.null;
    back_outer = c; }

(** Conversion from deep to shallow, where chunk c holds all the data *)

let set_shallow c s =
   s.front_outer <- c;  
   s.front_inner <- Chunk.null;
   s.middle <- empty();
   s.back_inner <- Chunk.null;
   s.back_outer <- c 

(** Emptiness test *)    
  
let is_empty s = 
   (* is_shallow s && Chunk.is_empty s.front_outer *)
   if is_shallow s then Chunk.is_empty s.front_outer else false

(** Push front *)

let rec push_front : 'a. 'a -> 'a t -> unit = fun x s ->
   let full_front = let c = s.front_outer in Chunk.is_full c in 
   if full_front then begin
      if is_shallow s then begin
         s.front_outer <- Chunk.create();  
         s.front_inner <- Chunk.create();  
         s.middle <- create();
         s.back_inner <- Chunk.create()
      end else begin
         let ci = s.front_inner in
         s.front_inner <- s.front_outer;
         if Chunk.is_empty ci then begin
            s.front_outer <- ci;
         end else begin
            (* assert (Chunk.is_full ci); *)
            push_front ci s.middle;
            s.front_outer <- Chunk.create();
         end
      end
   end;
   Chunk.push_front x s.front_outer

(** Push back *)

let rec push_back : 'a. 'a -> 'a t -> unit = fun x s ->
   assert false

(** Pop front *)

let rec pop_front : 'a. 'a t -> 'a = fun s -> 
   let co = s.front_outer in
   let check () = set_shallow_if_needed s in
   if not (Chunk.is_empty co) then begin
      let x = Chunk.pop_front co in
      if Chunk.length co <= 1 then check();
      x
   end else begin
      (* assert (not (is_shallow s)); *)
      let ci = s.front_inner in
      let m = s.middle in
      if not (Chunk.is_empty ci) then begin
         s.front_outer <- ci;
         s.front_inner <- co;
         Chunk.pop_front s.front_outer
      end else if not (is_empty m) then begin
         s.front_outer <- pop_front m;
         let x = Chunk.pop_front s.front_outer in
         check();
         x
      end else if not (Chunk.is_empty s.back_inner) then begin
         s.front_outer <- s.back_inner;
         s.back_inner <- co;
         Chunk.pop_front s.front_outer
      end else begin
         (* assert (not (Chunk.is_empty s.back_outer)); *)
         let bo = s.back_outer in
         let x = Chunk.pop_front bo in
         if Chunk.length bo <= 1 then check();
         x
      end
   end

(** Conversion from deep to shallow if the layer stores only 0 or 1 item *)

and set_shallow_if_needed : 'a. 'a t -> unit = fun s ->
   let fo = s.front_outer in
   let bo = s.back_outer in
   let mid = s.middle in
   let n = Chunk.length fo
         + Chunk.length s.front_inner 
         + Chunk.length s.back_inner 
         + Chunk.length bo in
   if n <= 1 && is_empty mid then begin
      let c = if Chunk.is_empty fo then bo else fo in
      set_shallow c s;
   end else if n = 0 then begin
      let c = pop_front mid in
      if Chunk.length c <= 1 && is_empty mid 
         then set_shallow c s
         else s.front_outer <- c
   end

(** Pop back *)

let pop_back : 'a. 'a t -> 'a = fun s -> 
   assert false

(** Front *)

let front : 'a. 'a t -> 'a = fun s -> 
   assert false

(** Back *)

let back : 'a. 'a t -> 'a = fun s -> 
   assert false

(** Push a buffer to the back of the middle sequence, 
    possibly merging it with the back chunk in the middle sequence *)

let middle_merge_back m c =
   let sc = Chunk.length c in
   if sc > 0 then begin
      if is_empty m then begin
         push_back c m
      end else begin
         let b = pop_back m in
         let sb = Chunk.length b in
         if sc + sb > Chunk.capacity then begin
            push_back b m;
            push_back c m
         end else begin
            Chunk.append b c;
            push_back b m;
         end
      end
   end

(** -- Symmetric to above *)

let middle_merge_front m c =
   assert false

(** Swap the content of two sequences *)

let swap_shallow_with_other : 'a. 'a t -> 'a t -> unit = fun s1 s2 ->
   let c = s1.front_outer in
   s1.front_outer <- s2.front_outer;  
   s1.front_inner <- s2.front_inner;
   s1.middle <- s2.middle;
   s1.back_inner <- s2.back_inner;
   s1.back_outer <- s2.back_outer;
   set_shallow c s2

(** Merge the items of a chunk to the back of a sequence *)

let append_chunk_back c s =
   while not (Chunk.is_empty c) do
      let x = Chunk.pop_front c in
      push_back x s;
   done
  (* Chunk.iter (fun x -> push_back x s) c *)

(** Merge the items of a chunk to the front of a sequence *)

let append_chunk_front c s =
   while not (Chunk.is_empty c) do
      let x = Chunk.pop_back c in
      push_front x s;
   done
   (* Chunk.iter (fun x -> push_front x s) c *)

(** Append to the back of q1 the items of s2; s2 becomes invalid *)

let rec append : 'a. 'a t -> 'a t -> unit = fun s1 s2 ->
   if is_shallow s2 then begin
      append_chunk_back s2.front_outer s1 
   end else if is_shallow s1 then begin
      swap_shallow_with_other s1 s2;
      append_chunk_front s2.front_outer s1
   end else begin
      let m1 = s1.middle in
      let ci = s1.back_inner in
      let co = s1.back_outer in
      if Chunk.is_empty ci then begin
         middle_merge_back m1 co
      end else begin
         push_back ci m1;
         if not (Chunk.is_empty co)
            then push_back co m1;
      end;
      let m2 = s2.middle in
      let ci = s2.front_inner in
      let co = s2.front_outer in
      if Chunk.is_empty ci then begin
         middle_merge_front m2 co
      end else begin
         push_front ci m2;
         if not (Chunk.is_empty co)
            then push_front co m2;
      end;
      s1.back_inner <- s2.back_inner;
      s1.back_outer <- s2.back_outer;
      if not (is_empty m1) && not (is_empty m2) then begin
         let c1 = pop_back m1 in
         let sc1 = Chunk.length c1 in
         let c2 = pop_front m2 in
         let sc2 = Chunk.length c2 in
         if sc1 + sc2 > Chunk.capacity then begin
            push_back c1 m1;
            push_front c2 m2;
         end else begin
            Chunk.append c1 c2;
            push_back c1 m1;
         end;
      end;
      append m1 m2;
   end


end