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
module Tries = struct
type 'a t = ST of 'a option * (char * 'a t) list
type key = string
exception Not_found
exception Conflict
let empty = ST (None, [])
let explode str =
let rec explode_aux i ls =
if i = -1 then ls else explode_aux (i - 1) (String.get str i :: ls)
in
explode_aux (String.length str - 1) []
let add ?(overwrite = false) id attr smtb =
let rec insert1 lts (ST (a, s)) =
match lts with
| [] -> (
match (a, overwrite) with
| None, _ -> ST (Some attr, s)
| Some _, true -> ST (Some attr, s)
| Some _, false -> raise Conflict)
| l :: rm -> ST (a, insert2 l rm s)
and insert2 lt lts stls =
match stls with
| [] -> [ (lt, insert1 lts empty) ]
| (l, i) :: rm ->
if lt = l then (lt, insert1 lts i) :: rm
else if lt <= l then (lt, insert1 lts empty) :: stls
else (l, i) :: insert2 lt lts rm
in
insert1 (explode id) smtb
let find w smtb =
let rec lookup1 lts (ST (a, s)) =
match lts with
| [] -> ( match a with None -> raise Not_found | Some b -> b)
| l :: rm -> lookup2 l rm s
and lookup2 lt lts stls =
match stls with
| [] -> raise Not_found
| (l, i) :: rm ->
if lt = l then lookup1 lts i
else if lt <= l then raise Not_found
else lookup2 lt lts rm
in
lookup1 (explode w) smtb
let implode lst =
let buff = Buffer.create (List.length lst) in
let () = List.fold_right (fun c _ -> Buffer.add_char buff c) lst () in
Buffer.contents buff
let fold f acc tr =
let rec fold_aux key acc = function
| ST (None, trs) ->
List.fold_left (fun acc (c, t) -> fold_aux (c :: key) acc t) acc trs
| ST (Some v, trs) ->
let new_acc = f (implode key) v acc in
List.fold_left
(fun acc (c, t) -> fold_aux (c :: key) acc t)
new_acc trs
in
fold_aux [] acc tr
let iter f tr =
let rec iter_aux key = function
| ST (None, trs) -> List.iter (fun (c, t) -> iter_aux (c :: key) t) trs
| ST (v, trs) ->
let () = match v with None -> () | Some v -> f (implode key) v in
List.iter (fun (c, t) -> iter_aux (c :: key) t) trs
in
iter_aux [] tr
let pp ?(sep = format_of_string "@,") ppf m tr =
let l_pp m (k, v) = ppf m k v in
let first = ref true in
iter
(fun k v ->
if !first then
let () = first := false in
ppf m k v
else Format.fprintf m (sep ^^ "%a") l_pp (k, v))
tr
end