(** Unicode collation algorithm *)

(* Copyright (C) 2002, 2003 Yamagata Yoriyuki *)

(* 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 of *)
(* the License, or (at your option) any later version. *)

(* As a special exception to the GNU Library General Public License, you *)
(* may link, statically or dynamically, a "work that uses this library" *)
(* with a publicly distributed version of this library to produce an *)
(* executable file containing portions of this library, and distribute *)
(* that executable file under terms of your choice, without any of the *)
(* additional requirements listed in clause 6 of the GNU Library General *)
(* Public License. By "a publicly distributed version of this library", *)
(* we mean either the unmodified Library as distributed by the authors, *)
(* or a modified version of this library that is distributed under the *)
(* conditions defined in clause 3 of the GNU Library General Public *)
(* License. This exception does not however invalidate any other reasons *)
(* why the executable file might be covered by the GNU Library General *)
(* Public 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 *)

(* You can contact the authour by sending email to *)
(* yoriyuki.y@gmail.com *)

type variable_option = [ `Blanked | `Non_ignorable | `Shifted | `Shift_Trimmed ]
type precision = [ `Primary | `Secondary | `Tertiary | `Quaternary ]

module type Type = sig
  type text
  type index

  (** For locale, see {!Locale}.
      If [locale] is omitted, the standard UCA order is used.
      If [prec] is omitted, the maximum possible strength is used.
      If [variable] is omitted, the default of the locale
      (usually [`Shifted]) is used.
      The meaning of the returned value is similar to Stdlib.compare *)
  val compare :
    ?locale:string ->
    ?prec:precision ->
    ?variable:variable_option ->
    text ->
    text ->
    int

  (** Binary comparison of sort_key gives the same result as [compare].
      i.e.
      [compare t1 t2 = Stdlib.compare (sort_key t1) (sort_key t2)]
      If the same texts are repeatedly compared,
      pre-computation of sort_key gives better performance. *)
  val sort_key :
    ?locale:string ->
    ?prec:precision ->
    ?variable:variable_option ->
    text ->
    string

  (** Comparison with the sort key. *)
  val compare_with_key :
    ?locale:string ->
    ?prec:precision ->
    ?variable:variable_option ->
    string ->
    text ->
    int

  val search_with_key :
    ?locale:string ->
    ?prec:precision ->
    ?variable:variable_option ->
    string ->
    text ->
    index ->
    index * index

  val search :
    ?locale:string ->
    ?prec:precision ->
    ?variable:variable_option ->
    text ->
    text ->
    index ->
    index * index
end

module Make (Config : Config.Type) (Text : UnicodeString.Type) = struct
  module Unidata = Unidata.Make (Config)
  module UCharInfo = UCharInfo.Make (Config)

  let logical_order_exception_tbl =
    UCharInfo.load_property_tbl `Logical_Order_Exception

  let is_logical_order_exception u =
    UCharTbl.Bool.get logical_order_exception_tbl u

  let rec rearrange_aux x pos =
    if pos > XString.length x - 2 then ()
    else (
      let u = XString.get x pos in
      if is_logical_order_exception u then begin
        XString.set x pos (XString.get x (pos + 1));
        XString.set x (pos + 1) u;
        rearrange_aux x (pos + 2)
      end
      else rearrange_aux x (pos + 1))

  let rearrange x = rearrange_aux x 0

  let remove_ignorable ce_tbl x =
    let rec loop0 i =
      if XString.length x <= i then ()
      else (
        let u = XString.get x i in
        match Unidata.ce ce_tbl u with
          | [([], [ce])] when ce = Unidata.complete_ignorable -> loop1 (i + 1) i
          | _ -> loop0 (i + 1))
    and loop1 i k =
      (*k < i *)
      if XString.length x <= i then begin
        XString.shrink x k
      end
      else (
        let u = XString.get x i in
        match Unidata.ce ce_tbl u with
          | [([], [ce])] when ce = Unidata.complete_ignorable -> loop1 (i + 1) k
          | _ ->
              XString.set x k u;
              loop1 (i + 1) (k + 1))
    in
    loop0 0

  let noncharacter_code_point_tbl =
    UCharInfo.load_property_tbl `Noncharacter_Code_Point

  let is_noncharacter_code_point u =
    UCharTbl.Bool.get noncharacter_code_point_tbl u

  let reverse s =
    if Bytes.length s = 0 then ()
    else (
      let last = Bytes.length s - 1 in
      for i = 0 to last / 2 do
        let c = Bytes.get s i in
        Bytes.set s i (Bytes.get s (last - i));
        Bytes.set s (last - i) c
      done)

  let shiftright x i j =
    for k = j downto i do
      XString.set x (k + 1) (XString.get x k)
    done

  let rec remove_chars x i = function
    | [] -> i
    | j :: rest ->
        shiftright x i (j - 1);
        remove_chars x (i + 1) rest

  let trim start_regular key =
    let rec loop i =
      if
        i > 0
        && (Char.code key.[i - 1] lsl 8) lor Char.code key.[i] > start_regular
      then loop (i - 2)
      else String.sub key 0 (i + 1)
    in
    loop (String.length key - 1)

  let is_variable variable_top ce =
    Unidata.primary ce <> 0 && Unidata.primary ce <= variable_top

  let is_ignorable ce = Unidata.primary ce = 0

  let add_i16 buf n =
    Buffer.add_char buf (Char.unsafe_chr (n lsr 8));
    Buffer.add_char buf (Char.unsafe_chr (n land 255))

  let add_byte buf n = Buffer.add_char buf (Char.unsafe_chr n)

  type non_ignorable_keybuf = {
    non_ignorable_col_info : Unidata.col_info;
    non_ignorable_prec : precision;
    non_ignorable_primary : Buffer.t;
    non_ignorable_secondary : Buffer.t;
    non_ignorable_tertiary : Buffer.t;
    non_ignorable_quaternary : Buffer.t;
    mutable non_ignorable_count : int;
  }

  let addce_non_ignorable keybuf ce =
    let w1 = Unidata.primary ce in
    if w1 <> 0 && w1 <> keybuf.non_ignorable_col_info.hiraganaQ_weight then
      add_i16 keybuf.non_ignorable_primary w1;
    match keybuf.non_ignorable_prec with
      | `Primary -> ()
      | _ -> (
          let w2 = Unidata.secondary ce in
          if w2 <> 0 then add_byte keybuf.non_ignorable_secondary w2;
          match keybuf.non_ignorable_prec with
            | `Secondary -> ()
            | _ -> (
                let w3 = Unidata.tertiary ce in
                if w3 <> 0 then add_byte keybuf.non_ignorable_tertiary w3;
                match keybuf.non_ignorable_prec with
                  | `Tertiary -> ()
                  | _ ->
                      if not keybuf.non_ignorable_col_info.hiraganaQ then ()
                      else if
                        w1 = keybuf.non_ignorable_col_info.hiraganaQ_weight
                      then begin
                        if keybuf.non_ignorable_count > 0 then begin
                          add_i16 keybuf.non_ignorable_quaternary
                            (1 + keybuf.non_ignorable_count);
                          keybuf.non_ignorable_count <- 0
                        end;
                        add_i16 keybuf.non_ignorable_quaternary 1
                      end
                      else begin
                        keybuf.non_ignorable_count <-
                          keybuf.non_ignorable_count + 1;
                        if keybuf.non_ignorable_count = 0xffff - 1 then begin
                          add_i16 keybuf.non_ignorable_quaternary 0xffff;
                          keybuf.non_ignorable_count <- 0
                        end
                      end))

  let terminate_non_ignorable keybuf =
    let c = keybuf.non_ignorable_count in
    if c > 0 then add_i16 keybuf.non_ignorable_quaternary (1 + c)

  type blanked_keybuf = {
    blanked_col_info : Unidata.col_info;
    blanked_prec : precision;
    blanked_primary : Buffer.t;
    blanked_secondary : Buffer.t;
    blanked_tertiary : Buffer.t;
    blanked_quaternary : Buffer.t;
    mutable blanked_after_variable : bool;
    mutable blanked_count : int;
  }

  let addce_blanked keybuf ce =
    if is_ignorable ce && keybuf.blanked_after_variable then ()
    else if is_variable keybuf.blanked_col_info.variable_top ce then
      keybuf.blanked_after_variable <- true
    else begin
      keybuf.blanked_after_variable <- false;
      let w1 = Unidata.primary ce in
      if w1 <> 0 && w1 <> keybuf.blanked_col_info.hiraganaQ_weight then
        add_i16 keybuf.blanked_primary w1;
      match keybuf.blanked_prec with
        | `Primary -> ()
        | _ -> (
            let w2 = Unidata.secondary ce in
            if w2 <> 0 then add_byte keybuf.blanked_secondary w2;
            match keybuf.blanked_prec with
              | `Secondary -> ()
              | _ -> (
                  let w3 = Unidata.tertiary ce in
                  if w3 <> 0 then add_byte keybuf.blanked_tertiary w3;
                  match keybuf.blanked_prec with
                    | `Tertiary -> ()
                    | _ ->
                        if not keybuf.blanked_col_info.hiraganaQ then ()
                        else if w1 = keybuf.blanked_col_info.hiraganaQ_weight
                        then begin
                          if keybuf.blanked_count > 0 then begin
                            add_i16 keybuf.blanked_quaternary
                              (1 + keybuf.blanked_count);
                            keybuf.blanked_count <- 0
                          end;
                          add_i16 keybuf.blanked_quaternary 1
                        end
                        else begin
                          keybuf.blanked_count <- keybuf.blanked_count + 1;
                          if keybuf.blanked_count = 0xffff - 1 then begin
                            add_i16 keybuf.blanked_quaternary 0xffff;
                            keybuf.blanked_count <- 0
                          end
                        end))
    end

  let terminate_blanked keybuf =
    let c = keybuf.blanked_count in
    if c > 0 then add_i16 keybuf.blanked_quaternary (1 + c)

  type shifted_keybuf = {
    shifted_col_info : Unidata.col_info;
    shifted_prec : precision;
    shifted_primary : Buffer.t;
    shifted_secondary : Buffer.t;
    shifted_tertiary : Buffer.t;
    shifted_quaternary : Buffer.t;
    mutable shifted_after_variable : bool;
    mutable shifted_count : int;
  }

  let start_regular keybuf =
    if keybuf.shifted_col_info.hiraganaQ then
      keybuf.shifted_col_info.hiraganaQ_weight
    else keybuf.shifted_col_info.variable_top

  let addce_shifted keybuf ce =
    let start_regular = start_regular keybuf in
    if is_ignorable ce && keybuf.shifted_after_variable then ()
    else if is_variable keybuf.shifted_col_info.variable_top ce then begin
      keybuf.shifted_after_variable <- true;
      match keybuf.shifted_prec with
        | `Quaternary ->
            if keybuf.shifted_count > 0 then begin
              add_i16 keybuf.shifted_quaternary
                (start_regular + keybuf.shifted_count);
              keybuf.shifted_count <- 0
            end;
            add_i16 keybuf.shifted_quaternary (Unidata.primary ce)
        | _ -> ()
    end
    else begin
      keybuf.shifted_after_variable <- false;
      let w1 = Unidata.primary ce in
      if w1 <> 0 && w1 <> keybuf.shifted_col_info.hiraganaQ_weight then
        add_i16 keybuf.shifted_primary w1;
      match keybuf.shifted_prec with
        | `Primary -> ()
        | _ -> (
            let w2 = Unidata.secondary ce in
            if w2 <> 0 then add_byte keybuf.shifted_secondary w2;
            match keybuf.shifted_prec with
              | `Secondary -> ()
              | _ -> (
                  let w3 = Unidata.tertiary ce in
                  if w3 <> 0 then add_byte keybuf.shifted_tertiary w3;
                  match keybuf.shifted_prec with
                    | `Tertiary -> ()
                    | _ ->
                        if is_ignorable ce then ()
                        else if
                          w1 = keybuf.shifted_col_info.hiraganaQ_weight
                          && keybuf.shifted_col_info.hiraganaQ
                        then begin
                          if keybuf.shifted_count > 0 then begin
                            add_i16 keybuf.shifted_quaternary
                              (start_regular + keybuf.shifted_count);
                            keybuf.shifted_count <- 0
                          end;
                          add_i16 keybuf.shifted_quaternary w1
                        end
                        else begin
                          keybuf.shifted_count <- keybuf.shifted_count + 1;
                          if keybuf.shifted_count = 0xffff - start_regular then begin
                            add_i16 keybuf.shifted_quaternary 0xffff;
                            keybuf.shifted_count <- 0
                          end
                        end))
    end

  let terminate_shifted keybuf =
    let c = keybuf.shifted_count in
    if c > 0 then add_i16 keybuf.shifted_quaternary (start_regular keybuf + c)

  let terminate_shift_trimmed keybuf =
    let k4 = Buffer.contents keybuf.shifted_quaternary in
    let k4 = trim (start_regular keybuf) k4 in
    Buffer.clear keybuf.shifted_quaternary;
    Buffer.add_string keybuf.shifted_quaternary k4

  type keybuf =
    | Non_ignorable of non_ignorable_keybuf
    | Blanked of blanked_keybuf
    | Shifted of shifted_keybuf
    | Shift_Trimmed of shifted_keybuf

  let create_keybuf prec col_info =
    match col_info.Unidata.variable_option with
      | `Non_ignorable ->
          Non_ignorable
            {
              non_ignorable_col_info = col_info;
              non_ignorable_prec = prec;
              non_ignorable_primary = Buffer.create 0;
              non_ignorable_secondary = Buffer.create 0;
              non_ignorable_tertiary = Buffer.create 0;
              non_ignorable_quaternary = Buffer.create 0;
              non_ignorable_count = 0;
            }
      | `Blanked ->
          Blanked
            {
              blanked_col_info = col_info;
              blanked_prec = prec;
              blanked_primary = Buffer.create 0;
              blanked_secondary = Buffer.create 0;
              blanked_tertiary = Buffer.create 0;
              blanked_quaternary = Buffer.create 0;
              blanked_after_variable = false;
              blanked_count = 0;
            }
      | `Shifted ->
          Shifted
            {
              shifted_col_info = col_info;
              shifted_prec = prec;
              shifted_primary = Buffer.create 0;
              shifted_secondary = Buffer.create 0;
              shifted_tertiary = Buffer.create 0;
              shifted_quaternary = Buffer.create 0;
              shifted_after_variable = false;
              shifted_count = 0;
            }
      | `Shift_Trimmed ->
          Shift_Trimmed
            {
              shifted_col_info = col_info;
              shifted_prec = prec;
              shifted_primary = Buffer.create 0;
              shifted_secondary = Buffer.create 0;
              shifted_tertiary = Buffer.create 0;
              shifted_quaternary = Buffer.create 0;
              shifted_after_variable = false;
              shifted_count = 0;
            }

  let col_info_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_col_info
    | Blanked b -> b.blanked_col_info
    | Shifted b | Shift_Trimmed b -> b.shifted_col_info

  let precision_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_prec
    | Blanked b -> b.blanked_prec
    | Shifted b | Shift_Trimmed b -> b.shifted_prec

  let primary_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_primary
    | Blanked b -> b.blanked_primary
    | Shifted b | Shift_Trimmed b -> b.shifted_primary

  let secondary_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_secondary
    | Blanked b -> b.blanked_secondary
    | Shifted b | Shift_Trimmed b -> b.shifted_secondary

  let tertiary_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_tertiary
    | Blanked b -> b.blanked_tertiary
    | Shifted b | Shift_Trimmed b -> b.shifted_tertiary

  let quaternary_of_keybuf = function
    | Non_ignorable b -> b.non_ignorable_quaternary
    | Blanked b -> b.blanked_quaternary
    | Shifted b | Shift_Trimmed b -> b.shifted_quaternary

  let addce keybuf ce =
    (*  Printf.printf "addce ce: %x " ce; *)
    match keybuf with
      | Non_ignorable keybuf -> addce_non_ignorable keybuf ce
      | Blanked keybuf -> addce_blanked keybuf ce
      | Shifted keybuf | Shift_Trimmed keybuf -> addce_shifted keybuf ce

  let terminate = function
    | Non_ignorable keybuf -> terminate_non_ignorable keybuf
    | Blanked keybuf -> terminate_blanked keybuf
    | Shifted keybuf -> terminate_shifted keybuf
    | Shift_Trimmed keybuf -> terminate_shift_trimmed keybuf

  let rec add_list keybuf = function
    | [] -> ()
    | e :: rest ->
        addce keybuf e;
        add_list keybuf rest

  let implicit_ce cebuf u =
    let n = UChar.uint_code u in
    if
      n < 0 || n > 0x10ffff
      || (match UCharInfo.general_category u with `Cs -> true | _ -> false)
      || is_noncharacter_code_point u
    then addce cebuf Unidata.complete_ignorable (*illegal code point*)
    else (
      let base =
        if n >= 0x4e00 && n <= 0x9fff then 0xfb40
        else if n >= 0x3400 && n <= 0x4dbf then 0xfb80
        else if n >= 0x20000 && n <= 0x2a6df then 0xfb80
        else 0xfbc0
      in
      let a = base + (n lsr 15) in
      let b = n land 0x7fff lor 0x8000 in
      addce cebuf (Unidata.compose_ce a 1 1);
      addce cebuf (Unidata.compose_ce b 0 0))

  let rec match_us2 x i c' = function
    | [] -> []
    | u :: rest as us ->
        if i >= XString.length x then raise Exit
        else (
          let u' = XString.get x i in
          let c = UCharInfo.combined_class u' in
          if c' = 0 || c = 0 || c' = c then raise Exit
          else if UChar.eq u u' then i :: match_us2 x (i + 1) c' rest
          else match_us2 x (i + 1) c us)

  let rec match_us1 x i = function
    | [] -> i
    | u :: rest as us ->
        if i >= XString.length x then raise Exit
        else (
          let u' = XString.get x i in
          if UChar.eq u u' then match_us1 x (i + 1) rest
          else (
            let ps = match_us2 x (i + 1) (UCharInfo.combined_class u') us in
            remove_chars x i ps))

  let rec longest_match ce_buf x i = function
    | [] -> assert false
    | (us, ces) :: rest -> (
        try
          let j = match_us1 x i us in
          add_list ce_buf ces;
          j
        with Exit -> longest_match ce_buf x i rest)

  let getce keybuf x i =
    let col_info = col_info_of_keybuf keybuf in
    let hiraganaQ_mark = Unidata.compose_ce col_info.hiraganaQ_weight 0 0 in
    let rec loop i =
      if i >= XString.length x then ()
      else (
        let u = XString.get x i in
        (match UCharInfo.script u with
          | `Hiragana when col_info.hiraganaQ -> addce keybuf hiraganaQ_mark
          | _ -> ());
        let i' =
          match Unidata.ce col_info.tbl u with
            | [] ->
                implicit_ce keybuf u;
                i + 1
            | [([], [ce])] ->
                addce keybuf ce;
                i + 1
            | info -> longest_match keybuf x (i + 1) info
        in
        loop i')
    in
    loop i

  let getkey keybuf =
    let col_info = col_info_of_keybuf keybuf in
    let prec = precision_of_keybuf keybuf in
    terminate keybuf;
    let buf1 = primary_of_keybuf keybuf in
    (match prec with
      | `Primary -> ()
      | _ -> (
          add_i16 buf1 0;
          let buf2 = secondary_of_keybuf keybuf in
          if col_info.french_accent then (
            let key2 = Buffer.to_bytes buf2 in
            reverse key2;
            Buffer.add_bytes buf1 key2)
          else Buffer.add_buffer buf1 buf2;
          match prec with
            | `Secondary -> ()
            | _ -> (
                add_i16 buf1 0;
                Buffer.add_buffer buf1 (tertiary_of_keybuf keybuf);
                match prec with
                  | `Tertiary -> ()
                  | _ ->
                      add_i16 buf1 0;
                      Buffer.add_buffer buf1 (quaternary_of_keybuf keybuf))));
    Buffer.contents buf1

  type text = Text.t
  type index = Text.index

  module NF = UNF.Make (Config) (Text)

  let sort_key_aux col_info prec t =
    let x = XString.make 0 (UChar.chr_of_uint 0) in
    NF.put_nfd x t;
    rearrange x;
    remove_ignorable col_info.Unidata.tbl x;
    let cebuf = create_keybuf prec col_info in
    getce cebuf x 0;
    getkey cebuf

  let sort_key ?locale ?prec ?variable text =
    let col_info =
      let default = Unidata.get_col_info ?locale () in
      match variable with
        | None -> default
        | Some v -> { default with variable_option = v }
    in
    let prec =
      match prec with
        | None -> (
            match col_info.variable_option with
              | `Shifted | `Shift_Trimmed -> `Quaternary
              | _ -> `Tertiary)
        | Some prec -> prec
    in
    sort_key_aux col_info prec text

  (* Incremental sorting and search *)
  let rec primaries_of_ces col_info = function
    | [] -> []
    | ce :: rest ->
        (*	  Printf.printf "ce: %x " ce; *)
        let w =
          let w = Unidata.primary ce in
          if w = col_info.Unidata.hiraganaQ_weight then 0
          else (
            match col_info.variable_option with
              | `Non_ignorable -> w
              | _ -> if is_variable col_info.variable_top ce then 0 else w)
        in
        if w = 0 then primaries_of_ces col_info rest
        else w :: primaries_of_ces col_info rest

  let rec inc_end i = `Inc ([], i, lazy (inc_end i))

  let inc_prim col_info (`Inc (ces, i, f)) =
    let rec loop i f ws =
      let (`Inc (ces, i', f)) = Lazy.force f in
      if ces = [] then `Inc (ws, i, lazy (inc_end i))
      else (
        match primaries_of_ces col_info ces with
          | [] -> loop i' f ws
          | ws' -> `Inc (ws, i, lazy (loop i' f ws')))
    in
    loop i f (primaries_of_ces col_info ces)

  let implicit_ce_list u =
    let n = UChar.uint_code u in
    if
      n < 0 || n > 0x10ffff
      ||
      match UCharInfo.general_category u with
        | `Cs -> true
        | _ -> false || is_noncharacter_code_point u
    then [Unidata.complete_ignorable] (*illegal code point*)
    else (
      let base =
        if n >= 0x4e00 && n <= 0x9fff then 0xfb40
        else if n >= 0x3400 && n <= 0x4dbf then 0xfb80
        else if n >= 0x20000 && n <= 0x2a6df then 0xfb80
        else 0xfbc0
      in
      let a = base + (n lsr 15) in
      let b = n land 0x7fff lor 0x8000 in
      [Unidata.compose_ce a 1 1; Unidata.compose_ce b 0 0])

  let rec inc_match_us2 i f us0 us1 c' = function
    | [] -> `Match (us0 @ us1, i, f)
    | u :: rest as us -> (
        match us1 with
          | [] ->
              let (`Inc (us1, i, f)) = Lazy.force f in
              if us1 = [] then `Not_Match else inc_match_us2 i f us0 us1 c' us
          | u' :: r' ->
              let c = UCharInfo.combined_class u' in
              if c' = 0 || c = 0 || c' = c then `Not_Match
              else if UChar.eq u u' then inc_match_us2 i f us0 r' c' rest
              else inc_match_us2 i f (us0 @ [u']) r' c us)

  let rec inc_match_us1 i f us1 = function
    | [] -> `Match (us1, i, f)
    | u :: rest as us -> (
        match us1 with
          | [] ->
              let (`Inc (us1, i, f)) = Lazy.force f in
              if us1 = [] then `Not_Match else inc_match_us1 i f us1 us
          | u' :: r' ->
              if UChar.eq u u' then inc_match_us1 i f r' rest
              else inc_match_us2 i f [u'] r' (UCharInfo.combined_class u') us)

  let rec inc_longest_match us i f = function
    | [] -> `Not_Match
    | (us1, ces) :: rest -> (
        match inc_match_us1 i f us us1 with
          | `Match (us, i, f) -> `Match (ces, us, i, f)
          | `Not_Match -> inc_longest_match us i f rest)

  let get_next_ce col_info i f u us =
    match Unidata.ce col_info.Unidata.tbl u with
      | [] -> (implicit_ce_list u, us, i, f)
      | [([], ces)] -> (ces, us, i, f)
      | info -> (
          match inc_longest_match us i f info with
            | `Not_Match -> (implicit_ce_list u, us, i, f)
            | `Match (ces, us, i, f) -> (ces, us, i, f))

  let get_ces col_info f t i =
    let hiraganaQ_mark =
      Unidata.compose_ce col_info.Unidata.hiraganaQ_weight 0 0
    in
    let rec loop i f a = function
      | [] -> (
          match Lazy.force f with
            | `Inc ([], i, _) -> `Inc (a, i, lazy (inc_end i))
            | `Inc (us, i', f) -> (
                match a with
                  | [] -> loop i' f a us
                  | _ -> `Inc (a, i, lazy (loop i' f [] us))))
      | u :: us ->
          let a =
            match UCharInfo.script u with
              | `Hiragana when col_info.hiraganaQ -> a @ [hiraganaQ_mark]
              | _ -> a
          in
          let ces, us, i, f = get_next_ce col_info i f u us in
          loop i f (a @ ces) us
    in
    let (`Inc (us, i, f)) = f t i in
    loop i f [] us

  let inc_prep col_info f t i =
    let rec loop i f prev a = function
      | [] -> (
          match (a, prev) with
            | [], _ | _, [_] -> (
                match Lazy.force f with
                  | `Inc ([], i, _) -> `Inc (a @ prev, i, lazy (inc_end i))
                  | `Inc (us, i, f) -> loop i f prev a us)
            | _ -> `Inc (a, i, lazy (loop i f [] [] [])))
      | u :: rest -> (
          (*	    Printf.printf "prep uchar %x " (UChar.code u); *)
          match Unidata.ce col_info.Unidata.tbl u with
            | [([], [ce])] when ce = Unidata.complete_ignorable ->
                (*		Printf.printf "discarded "; *)
                loop i f prev a rest
            | _ -> (
                match prev with
                  | [] ->
                      if is_logical_order_exception u then loop i f [u] a rest
                      else loop i f [] (a @ [u]) rest
                  | [u0] -> loop i f [] (a @ [u; u0]) rest
                  | _ -> assert false))
    in
    let (`Inc (us, i, f)) = f t i in
    loop i f [] [] us

  let inc_ce col_info t i = get_ces col_info (inc_prep col_info NF.nfd_inc) t i

  let key_of_inc prec col_info x =
    let keybuf = create_keybuf prec col_info in
    let rec loop (`Inc (ces, _, f)) =
      add_list keybuf ces;
      match ces with [] -> () | _ -> loop (Lazy.force f)
    in
    loop x;
    getkey keybuf

  let null_weight f =
    match Lazy.force f with `Inc ([], _, _) -> true | _ -> false

  let inc_compare prec col_info t1 t2 =
    let rec loop f1 f2 ws1 ws2 =
      match (ws1, ws2) with
        | w1 :: rest1, w2 :: rest2 ->
            let sgn = w1 - w2 in
            if sgn = 0 then loop f1 f2 rest1 rest2 else sgn
        | [], ws2 ->
            let (`Inc (ws1, _, f1)) = Lazy.force f1 in
            if ws1 = [] then if ws2 = [] && null_weight f2 then 0 else ~-1
            else loop f1 f2 ws1 ws2
        | ws1, [] ->
            let (`Inc (ws2, _, f2)) = Lazy.force f2 in
            if ws2 = [] then 1 else loop f1 f2 ws1 ws2
    in
    let x1 = inc_ce col_info t1 (Text.nth t1 0) in
    let x2 = inc_ce col_info t2 (Text.nth t1 0) in
    let (`Inc (ws1, _, g1)) = inc_prim col_info x1 in
    let (`Inc (ws2, _, g2)) = inc_prim col_info x2 in
    let sgn = loop g1 g2 ws1 ws2 in
    if sgn <> 0 then sgn
    else (
      match prec with
        | `Primary -> 0
        | _ ->
            let key1 = key_of_inc prec col_info x1 in
            let key2 = key_of_inc prec col_info x2 in
            Stdlib.compare key1 key2)

  let compare ?locale ?prec ?variable t1 t2 =
    let col_info =
      let default = Unidata.get_col_info ?locale () in
      match variable with
        | None -> default
        | Some v -> { default with variable_option = v }
    in
    let prec =
      match prec with
        | None -> (
            match col_info.variable_option with
              | `Shifted | `Shift_Trimmed -> `Quaternary
              | _ -> `Tertiary)
        | Some prec -> prec
    in
    inc_compare prec col_info t1 t2

  let get_weight k i = (Char.code k.[i] lsl 8) lor Char.code k.[i + 1]

  let rec primary_length k i =
    if String.length k <= i || get_weight k i = 0 then i
    else primary_length k (i + 2)

  let inc_compare_key prec col_info k t =
    let k_len = primary_length k 0 in
    let rec loop f ws i =
      match ws with
        | w :: rest ->
            (*	    Printf.printf "prim %x " w;  *)
            if k_len <= i then ~-1
            else (
              let w' = get_weight k i in
              let sgn = w' - w in
              if sgn = 0 then loop f rest (i + 2) else sgn)
        | [] ->
            let (`Inc (ws, _, f)) = Lazy.force f in
            if ws = [] then
              if k_len = i then 0 else if k_len > i then 1 else assert false
            else loop f ws i
    in
    let x = inc_ce col_info t (Text.nth t 0) in
    let (`Inc (ws, _, g)) = inc_prim col_info x in
    let sgn = loop g ws 0 in
    (*      print_newline ();*)
    if sgn <> 0 then sgn
    else (
      match prec with
        | `Primary -> 0
        | _ ->
            let key = key_of_inc prec col_info x in
            (*      Printf.printf "key_of_inc %s\n" (String.escaped key);*)
            Stdlib.compare k key)

  let compare_with_key ?locale ?prec ?variable k t =
    let col_info =
      let default = Unidata.get_col_info ?locale () in
      match variable with
        | None -> default
        | Some v -> { default with variable_option = v }
    in
    let prec =
      match prec with
        | None -> (
            match col_info.variable_option with
              | `Shifted | `Shift_Trimmed -> `Quaternary
              | _ -> `Tertiary)
        | Some prec -> prec
    in
    inc_compare_key prec col_info k t

  let search_common col_info prec k t loc =
    let k_len = primary_length k 0 in
    let rec null i f =
      let (`Inc (ces, j, f)) = Lazy.force f in
      if primaries_of_ces col_info ces = [] then null j f else i
    in
    let rec test_match i f j = function
      | w :: rest ->
          (*	    Printf.printf "prim %x : loc %d " w j; *)
          if k_len <= j then raise Exit
          else (
            let w' = get_weight k j in
            if w' = w then test_match i f (j + 2) rest else raise Exit)
      | [] ->
          if k_len = j then (i, null i f)
          else (
            let (`Inc (ces, i, f)) = Lazy.force f in
            if ces = [] then raise Exit
            else test_match i f j (primaries_of_ces col_info ces))
    in
    let keys loc f i j ces =
      let keybuf = create_keybuf prec col_info in
      add_list keybuf ces;
      let rec loop f ks =
        let (`Inc (ces, loc, f)) = Lazy.force f in
        if Text.compare_index t loc j > 0 || ces = [] then ks
        else begin
          add_list keybuf ces;
          if Text.compare_index t loc i >= 0 then
            loop f ((getkey keybuf, i) :: ks)
          else loop f ks
        end
      in
      if Text.compare_index t loc i >= 0 then loop f [(getkey keybuf, i)]
      else loop f []
    in
    let rec scan loc f =
      let (`Inc (ces, i, f)) = Lazy.force f in
      if ces = [] then raise Not_found
      else (
        try
          let i, j = test_match i f 0 (primaries_of_ces col_info ces) in
          match prec with
            | `Primary -> (loc, j)
            | _ -> (
                let ks = keys loc f i j ces in
                (*	      Printf.printf "%s %s " (String.escaped k) (String.escaped k'); *)
                try (loc, List.assoc k ks) with Not_found -> raise Exit)
        with Exit -> scan i f)
    in
    scan loc (lazy (inc_ce col_info t loc))

  let search_with_key ?locale ?prec ?variable k t loc =
    let col_info =
      let default = Unidata.get_col_info ?locale () in
      match variable with
        | None -> default
        | Some v -> { default with variable_option = v }
    in
    let prec =
      match prec with
        | None -> (
            match col_info.variable_option with
              | `Shifted | `Shift_Trimmed -> `Quaternary
              | _ -> `Tertiary)
        | Some prec -> prec
    in
    search_common col_info prec k t loc

  let search ?locale ?prec ?variable t0 t loc =
    let k = sort_key ?locale ?prec ?variable t0 in
    search_with_key ?locale ?prec ?variable k t loc
end
