(*

 * ExtList - additional and modified functions for lists.

 * Copyright (C) 2003 Brian Hurt

 * Copyright (C) 2003 Nicolas Cannasse

 * Copyright (C) 2008 Red Hat Inc.

 * 

 * This library is free software; you can redistribute it and/or

 * modify it under the terms of the GNU Lesser General Public

 * License as published by the Free Software Foundation; either

 * version 2.1 of the License, or (at your option) any later version,

 * with the special exception on linking described in file LICENSE.

 *

 * This library is distributed in the hope that it will be useful,

 * but WITHOUT ANY WARRANTY; without even the implied warranty of

 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

 * Lesser General Public License for more details.

 *

 * You should have received a copy of the GNU Lesser General Public

 * License along with this library; if not, write to the Free Software

 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

 *)

module List = struct

exception Empty_list

exception Invalid_index of int

exception Different_list_size of string

include List

(* Thanks to Jacques Garrigue for suggesting the following structure *)

type 'a mut_list =  {

  hd: 'a; 

  mutable tl: 'a list

}

external inj : 'a mut_list -> 'a list = "%identity"

let dummy_node () = { hd = Obj.magic (); tl = [] }

let hd = function

  | [] -> raise Empty_list

  | h :: t -> h

let tl = function

  | [] -> raise Empty_list

  | h :: t -> t

let nth l index =

  if index < 0 then raise (Invalid_index index);

  let rec loop n = function

    | [] -> raise (Invalid_index index);

    | h :: t ->

      if n = 0 then h else loop (n - 1) t

  in

  loop index l

let append l1 l2 =

  match l1 with

  | [] -> l2

  | h :: t ->

    let rec loop dst = function

    | [] ->

      dst.tl <- l2

    | h :: t ->

      let cell = { hd = h; tl = [] } in

      dst.tl <- inj cell;

      loop cell t

    in

    let r = { hd = h; tl = [] } in

    loop r t;

    inj r

let rec flatten l =

  let rec inner dst = function

    | [] -> dst

    | h :: t ->

      let r = { hd = h; tl = [] } in

      dst.tl <- inj r;

      inner r t

  in

  let rec outer dst = function

    | [] -> ()

    | h :: t -> outer (inner dst h) t

  in

  let r = dummy_node () in

  outer r l;

  r.tl

let concat = flatten

let map f = function

  | [] -> []

  | h :: t ->

    let rec loop dst = function

    | [] -> ()

    | h :: t ->

      let r = { hd = f h; tl = [] } in

      dst.tl <- inj r;

      loop r t

    in

    let r = { hd = f h; tl = [] } in

    loop r t;

    inj r

let rec drop n = function

  | _ :: l when n > 0 -> drop (n-1) l

  | l -> l

let take n l =

  let rec loop n dst = function

    | h :: t when n > 0 ->

      let r = { hd = h; tl = [] } in

      dst.tl <- inj r;

      loop (n-1) r t

    | _ ->

      ()

  in

  let dummy = dummy_node() in

  loop n dummy l;

  dummy.tl

(* takewhile and dropwhile by Richard W.M. Jones. *)

let rec takewhile f = function

  | [] -> []

  | x :: xs when f x -> x :: takewhile f xs

  | _ -> []

let rec dropwhile f = function

  | [] -> []

  | x :: xs when f x -> dropwhile f xs

  | xs -> xs

let rec unique ?(cmp = ( = )) l =

  let rec loop dst = function

    | [] -> ()

    | h :: t ->

      match exists (cmp h) t with

      | true -> loop dst t

      | false ->

        let r = { hd =  h; tl = [] }  in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node() in

  loop dummy l;

  dummy.tl

let filter_map f l =

  let rec loop dst = function

    | [] -> ()

    | h :: t ->

      match f h with

      | None -> loop dst t

      | Some x ->

        let r = { hd = x; tl = [] }  in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node() in

  loop dummy l;

  dummy.tl

let rec find_map f = function

  | [] -> raise Not_found

  | x :: xs ->

      match f x with

      | Some y -> y

      | None -> find_map f xs

let fold_right_max = 1000

let fold_right f l init =

  let rec tail_loop acc = function

    | [] -> acc

    | h :: t -> tail_loop (f h acc) t

  in

  let rec loop n = function

    | [] -> init

    | h :: t ->

      if n < fold_right_max then

        f h (loop (n+1) t)

      else

        f h (tail_loop init (rev t))

  in

  loop 0 l

let map2 f l1 l2 =

  let rec loop dst src1 src2 =

    match src1, src2 with

      | [], [] -> ()

      | h1 :: t1, h2 :: t2 ->

        let r = { hd = f h1 h2; tl = [] } in

        dst.tl <- inj r;

        loop r t1 t2

      | _ -> raise (Different_list_size "map2")

  in

  let dummy = dummy_node () in

  loop dummy l1 l2;

  dummy.tl

let rev_map2 f l1 l2 =

  let rec loop acc l1 l2 =

    match l1, l2 with

    | [], [] -> acc

    | h1 :: t1, h2 :: t2 -> loop (f h1 h2 :: acc) t1 t2

    | _ -> raise (Different_list_size "rev_map2")

  in

  loop [] l1 l2

let rec iter2 f l1 l2 =

  match l1, l2 with

  | [], [] -> ()

  | h1 :: t1, h2 :: t2 -> f h1 h2; iter2 f t1 t2

  | _ -> raise (Different_list_size "iter2")

let rec fold_left2 f accum l1 l2 =

  match l1, l2 with

  | [], [] -> accum

  | h1 :: t1, h2 :: t2 -> fold_left2 f (f accum h1 h2) t1 t2

  | _ -> raise (Different_list_size "fold_left2")

let fold_right2 f l1 l2 init =

  let rec tail_loop acc l1 l2 =

    match l1, l2 with

    | [] , [] -> acc

    | h1 :: t1 , h2 :: t2 -> tail_loop (f h1 h2 acc) t1 t2

    | _ -> raise (Different_list_size "fold_right2")

  in

  let rec loop n l1 l2 =

    match l1, l2 with

    | [], [] -> init

    | h1 :: t1, h2 :: t2 ->

      if n < fold_right_max then

        f h1 h2 (loop (n+1) t1 t2)

      else

        f h1 h2 (tail_loop init (rev t1) (rev t2))

    | _ -> raise (Different_list_size "fold_right2")

  in

  loop 0 l1 l2

let for_all2 p l1 l2 =

  let rec loop l1 l2 =

    match l1, l2 with

    | [], [] -> true

    | h1 :: t1, h2 :: t2 -> if p h1 h2 then loop t1 t2 else false

    | _ -> raise (Different_list_size "for_all2")

  in

  loop l1 l2

let exists2 p l1 l2 =

  let rec loop l1 l2 =

    match l1, l2 with

      | [], [] -> false

      | h1 :: t1, h2 :: t2 -> if p h1 h2 then true else loop t1 t2

      | _ -> raise (Different_list_size "exists2")

  in

  loop l1 l2

let remove_assoc x lst = 

  let rec loop dst = function

    | [] -> ()

    | (a, _ as pair) :: t ->

      if a = x then

        dst.tl <- t

      else

        let r = { hd = pair; tl = [] } in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node () in

  loop dummy lst;

  dummy.tl

let remove_assq x lst = 

  let rec loop dst = function

    | [] -> ()

    | (a, _ as pair) :: t ->

      if a == x then

        dst.tl <- t

      else

        let r = { hd =  pair; tl = [] } in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node() in

  loop dummy lst;

  dummy.tl

let rfind p l = find p (rev l)

let find_all p l = 

  let rec findnext dst = function

    | [] -> ()

    | h :: t -> 

      if p h then

        let r = { hd = h; tl = [] } in

        dst.tl <- inj r;

        findnext r t

      else

        findnext dst t

  in

  let dummy = dummy_node () in

  findnext dummy l;

  dummy.tl

let rec findi p l =

  let rec loop n = function

    | [] -> raise Not_found

    | h :: t ->

      if p n h then (n,h) else loop (n+1) t

  in

  loop 0 l

let filter = find_all

let partition p lst = 

  let rec loop yesdst nodst = function

    | [] -> ()

    | h :: t ->

      let r = { hd = h; tl = [] } in

      if p h then

        begin

          yesdst.tl <- inj r;

          loop r nodst t

        end

      else

        begin

          nodst.tl <- inj r;

          loop yesdst r t

        end

  in

  let yesdummy = dummy_node()

  and nodummy = dummy_node()

  in

  loop yesdummy nodummy lst;

  yesdummy.tl, nodummy.tl

let split lst =

  let rec loop adst bdst = function

    | [] -> ()

    | (a, b) :: t -> 

      let x = { hd = a; tl = [] } 

      and y = { hd = b; tl = [] } in

      adst.tl <- inj x;

      bdst.tl <- inj y;

      loop x y t

  in

  let adummy = dummy_node ()

  and bdummy = dummy_node ()

  in

  loop adummy bdummy lst;

  adummy.tl, bdummy.tl

let combine l1 l2 =

  let rec loop dst l1 l2 =

    match l1, l2 with

    | [], [] -> ()

    | h1 :: t1, h2 :: t2 -> 

      let r = { hd = h1, h2; tl = [] } in

      dst.tl <- inj r;

      loop r t1 t2

    | _, _ -> raise (Different_list_size "combine")

  in

  let dummy = dummy_node () in

  loop dummy l1 l2;

  dummy.tl

let sort ?(cmp=compare) = List.sort cmp

#if OCAML < 406

let rec init size f =

  if size = 0 then []

  else if size < 0 then invalid_arg "ExtList.init"

  else

    let rec loop dst n =

      if n < size then

        let r = { hd = f n; tl = [] } in

        dst.tl <- inj r;

        loop r (n+1)

    in

    let r = { hd = f 0; tl = [] } in

    loop r 1;

    inj r

#endif

let make i x =

  if i < 0 then invalid_arg "ExtList.List.make";

  let rec loop acc x = function

  | 0 -> acc

  | i -> loop (x::acc) x (i-1)

  in

  loop [] x i

let mapi f = function

  | [] -> []

  | h :: t ->

    let rec loop dst n = function

      | [] -> ()

      | h :: t ->

        let r = { hd = f n h; tl = [] } in

        dst.tl <- inj r;

        loop r (n+1) t

    in

    let r = { hd = f 0 h; tl = [] } in

    loop r 1 t;

    inj r

#if OCAML < 400

let iteri f l =

  let rec loop n = function

    | [] -> ()

    | h :: t ->

      f n h;

      loop (n+1) t

  in

  loop 0 l

#endif

let first = hd

let rec last = function

  | [] -> raise Empty_list

  | h :: [] -> h

  | _ :: t -> last t

let split_nth index = function

  | [] -> if index = 0 then [],[] else raise (Invalid_index index)

  | (h :: t as l) ->

    if index = 0 then [],l

    else if index < 0 then raise (Invalid_index index)

    else

      let rec loop n dst l =

        if n = 0 then l else

        match l with

        | [] -> raise (Invalid_index index)

        | h :: t ->

          let r = { hd =  h; tl = [] } in

          dst.tl <- inj r;

          loop (n-1) r t 

      in

      let r = { hd = h; tl = [] } in

      inj r, loop (index-1) r t

let find_exc f e l =

  try

    find f l

  with

    Not_found -> raise e

let remove l x =

  let rec loop dst = function

    | [] -> ()

    | h :: t ->

      if x = h then 

        dst.tl <- t

      else

        let r = { hd = h; tl = [] } in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node () in

  loop dummy l;

  dummy.tl

let rec remove_if f lst =

  let rec loop dst = function

    | [] -> ()

    | x :: l ->

      if f x then

        dst.tl <- l

      else

        let r = { hd = x; tl = [] } in

        dst.tl <- inj r;

        loop r l

  in

  let dummy = dummy_node () in

  loop dummy lst;

  dummy.tl

let rec remove_all l x =

  let rec loop dst = function

    | [] -> ()

    | h :: t ->

      if x = h then

        loop dst t

      else

        let r = { hd = h; tl = [] } in

        dst.tl <- inj r;

        loop r t

  in

  let dummy = dummy_node () in

  loop dummy l;

  dummy.tl

let enum l =

  let rec make lr count =

    Enum.make

      ~next:(fun () ->

        match !lr with

        | [] -> raise Enum.No_more_elements

        | h :: t ->

          decr count;

          lr := t;

          h

      )

      ~count:(fun () ->

        if !count < 0 then count := length !lr;

        !count

      )

      ~clone:(fun () ->

        make (ref !lr) (ref !count)

      )

  in

  make (ref l) (ref (-1))

let of_enum e =

  let h = dummy_node() in

  let _ = Enum.fold (fun x acc ->

    let r = { hd = x; tl = [] }  in

    acc.tl <- inj r;

    r) h e in

  h.tl

#if OCAML < 403

let cons x l = x :: l

#endif

#if OCAML < 405

let assoc_opt k l = try Some (assoc k l) with Not_found -> None

let assq_opt k l = try Some (assq k l) with Not_found -> None

let find_opt p l = try Some (find p l) with Not_found -> None

let nth_opt =

  let rec loop n = function

    | [] -> None

    | h :: t ->

      if n = 0 then Some h else loop (n - 1) t

  in

  fun l index -> if index < 0 then None else loop index l

let rec compare_lengths l1 l2 =

  match l1, l2 with

  | [], [] -> 0

  | [], _ -> -1

  | _, [] -> 1

  | _ :: l1, _ :: l2 -> compare_lengths l1 l2

let rec compare_length_with l n =

  match l, n with

  | [], 0 -> 0

  | [], _ -> if n > 0 then -1 else 1

  | _, 0 -> 1

  | _ :: l, n -> compare_length_with l (n-1)

#endif

end

let ( @ ) = List.append