1(*
2 * Copyright (C) 2008-2009 Citrix Ltd.
3 * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU Lesser General Public License as published
7 * by the Free Software Foundation; version 2.1 only. with the special
8 * exception on linking described in file LICENSE.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 * GNU Lesser General Public License for more details.
14 *)
15
16module Node =
17struct
18	type ('a,'b) t =  {
19		key: 'a;
20		value: 'b option;
21		children: ('a,'b) t list;
22	}
23
24	let _create key value = {
25		key = key;
26		value = Some value;
27		children = [];
28	}
29
30	let empty key = {
31		key = key;
32		value = None;
33		children = []
34	}
35
36	let _get_key node = node.key
37	let get_value node =
38		match node.value with
39		| None       -> raise Not_found
40		| Some value -> value
41
42	let _get_children node = node.children
43
44	let set_value node value =
45		{ node with value = Some value }
46	let set_children node children =
47		{ node with children = children }
48
49	let _add_child node child =
50		{ node with children = child :: node.children }
51end
52
53type ('a,'b) t = ('a,'b) Node.t list
54
55let mem_node nodes key =
56	List.exists (fun n -> n.Node.key = key) nodes
57
58let find_node nodes key =
59	List.find (fun n -> n.Node.key = key) nodes
60
61let replace_node nodes key node =
62	let rec aux = function
63		| []                            -> []
64		| h :: tl when h.Node.key = key -> node :: tl
65		| h :: tl                       -> h :: aux tl
66	in
67	aux nodes
68
69let remove_node nodes key =
70	let rec aux = function
71		| []                            -> raise Not_found
72		| h :: tl when h.Node.key = key -> tl
73		| h :: tl                       -> h :: aux tl
74	in
75	aux nodes
76
77let create () = []
78
79let rec iter f tree =
80	let aux node =
81		f node.Node.key node.Node.value;
82		iter f node.Node.children
83	in
84	List.iter aux tree
85
86let rec map f tree =
87	let aux node =
88		let value =
89			match node.Node.value with
90			| None       -> None
91			| Some value -> f value
92		in
93		{ node with Node.value = value; Node.children = map f node.Node.children }
94	in
95	List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree)
96
97let rec fold f tree acc =
98	let aux accu node =
99		fold f node.Node.children (f node.Node.key node.Node.value accu)
100	in
101	List.fold_left aux acc tree
102
103(* return a sub-trie *)
104let rec sub_node tree = function
105	| []   -> raise Not_found
106	| h::t ->
107		  if mem_node tree h
108		  then begin
109			  let node = find_node tree h in
110			  if t = []
111			  then node
112			  else sub_node node.Node.children t
113		  end else
114			  raise Not_found
115
116let sub tree path =
117	try (sub_node tree path).Node.children
118	with Not_found -> []
119
120let find tree path =
121	Node.get_value (sub_node tree path)
122
123(* return false if the node doesn't exists or if it is not associated to any value *)
124let rec mem tree = function
125	| []   -> false
126	| h::t ->
127		  mem_node tree h
128		  && (let node = find_node tree h in
129			  if t = []
130			  then node.Node.value <> None
131			  else mem node.Node.children t)
132
133(* Iterate over the longest valid prefix *)
134let rec iter_path f tree = function
135	| []   -> ()
136	| h::l ->
137		  if mem_node tree h
138		  then begin
139			  let node = find_node tree h in
140			  f node.Node.key node.Node.value;
141			  iter_path f node.Node.children l
142		  end
143
144let rec set_node node path value =
145	if path = []
146	then Node.set_value node value
147	else begin
148		let children = set node.Node.children path value in
149		Node.set_children node children
150	end
151
152and set tree path value =
153	match path with
154		| []   -> raise Not_found
155		| h::t ->
156			  if mem_node tree h
157			  then begin
158				  let node = find_node tree h in
159				  replace_node tree h (set_node node t value)
160			  end else begin
161				  let node = Node.empty h in
162				  set_node node t value :: tree
163			  end
164
165let rec unset tree = function
166	| []   -> tree
167	| h::t ->
168		  if mem_node tree h
169		  then begin
170			  let node = find_node tree h in
171			  let children = unset node.Node.children t in
172			  let new_node =
173				  if t = []
174				  then Node.set_children (Node.empty h) children
175				  else Node.set_children node children
176			  in
177			  if children = [] && new_node.Node.value = None
178			  then remove_node tree h
179			  else replace_node tree h new_node
180		  end else
181			  raise Not_found
182
183