Source file key.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2021 DaiLambda, Inc. <contact@dailambda.jp>                 *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Utils

type t = Segment.fat list

let encoding =
  Data_encoding.conv
    (fun xs -> List.map Segment.unfat xs)
    (fun segs -> List.map (fun x -> [`Segment x]) segs)
  @@ Data_encoding.list Segment.encoding

type gside = Left | Right | Bud

(* null ([]) is invalid *)
let empty = [[]]

let of_segments ss = [] :: List.map (fun x -> [`Segment x]) ss

let of_path p = of_segments @@ Path.to_segments p

let to_path = function
  | s::ss when Segment.(is_empty (unfat s)) -> Some (Path.of_segments (List.map Segment.unfat ss))
  | _ -> None

let to_segments = function
  | s::ss when Segment.(is_empty (unfat s)) -> `From_Bud (List.map Segment.unfat ss)
  | ss -> `From_non_Bud (List.map Segment.unfat ss)

let is_empty = function
  | [] -> assert false
  | [s] -> Segment.(is_empty (unfat s))
  | _ -> false

let rec cut = function
  | [] -> assert false
  | s::ss ->
      match s with
      | [] ->
          begin match ss with
            | [] -> None
            | _ -> Some (Bud, ss)
          end
      | `Left::s -> Some (Left, s::ss)
      | `Right::s -> Some (Right, s::ss)
      | `Segment seg::s ->
          match Segment.cut seg with
          | None -> cut (s::ss)
          | Some (side, seg) ->
              let side =
                match side with
                | Segment.Left -> Left
                | Right -> Right
              in
              Some (side, (`Segment seg :: s)::ss)

let has_prefix seg = function
  | [] -> assert false
  | s::ss ->
      match Segment.common_prefix seg (Segment.unfat s) with
      | _, seg', s' when Segment.is_empty seg' -> Some ([`Segment s']::ss)
      | _ -> None

let is_prefix k seg = match k with
  | [] -> assert false
  | [sk] ->
    begin match Segment.common_prefix seg (Segment.unfat sk) with
      | _, seg', sk' when Segment.is_empty sk' -> Some seg'
      | _ -> None
    end
  | _ -> None

let to_string t =
  let buf = Buffer.create 10 in
  Buffer.add_char buf '\'';
  let rec f t = match cut t with
    | None ->
        Buffer.add_char buf '\'';
        Buffer.contents buf
    | Some (gside, t) ->
        Buffer.add_char buf
          (match gside with
           | Bud -> '/'
           | Left -> 'L'
           | Right -> 'R');
        f t
  in
  f t

let pp ppf t = Format.pp_print_string ppf (to_string t)

let cons gside ss =
  match gside, ss with
  | _, [] -> assert false
  | Bud, ss -> []::ss
  | Left, s::ss -> (`Left::s) :: ss
  | Right, s::ss -> (`Right::s) :: ss

let keys view n =
  let rec f n =
    match view n with
    | Node_type.Bud (None, _, _) | Leaf _ -> [empty]
    | Bud (Some n, _, _) -> List.map (cons Bud) @@ f n
    | Internal (n1, n2, _, _) ->
        List.map (cons Left) (f n1)
        @ List.map (cons Right) (f n2)
    | Extender (s, n, _, _) ->
        let append_s = function
          | [] -> assert false
          | s'::ss -> (`Segment s :: s') :: ss
        in
        List.map append_s (f n)
  in
  f n