Source file key.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
(*****************************************************************************)
(*                                                                           *)
(* 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