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
|
(* The type of elements *)
type kind = Start | Stop | Other
(* Recursively remove consecutive start/stop pairs *)
let rec remove_matches = function
(Start, _) as start :: l ->
(match remove_matches l with
(Stop, _) :: rest -> rest
| rest -> start :: rest)
| (Stop, _) as stop :: l -> stop :: remove_matches l
| (Other, _) as x :: l -> x :: remove_matches l
| [] -> []
(* Annotate innermost start/stop pairs *)
let rec annotate_innermost f = function
(Start, a) :: l ->
let other, next_stop = find_stop f [] l in
(match next_stop with
(Stop, b) :: rest ->
(Start, f true a) :: other @ (Stop, f true b) ::
annotate_innermost f rest
| (Start, _) :: _ -> other @ annotate_innermost f next_stop
| (Other, _) :: _ -> assert false
| [] -> other)
| (tag, x) :: l -> (tag, f false x) :: annotate_innermost f l
| [] -> []
and find_stop f accu = function
(Other, x) :: l -> find_stop f ((Other, f false x) :: accu) l
| l -> (List.rev accu), l
let start x = (Start, x);;
let stop x = (Stop, x);;
let other x = (Other, x);;
let annotate b x = (x, b);;
let l1, l2 =
[ stop 1; stop 2; start 3; start 4; start 5; stop 5; start 6 ],
[ stop 6; start 7; stop 7; stop 4; stop 3; start 8; stop 8; start 9 ];;
let l = remove_matches (l1 @ [other 10] @ l2);;
annotate_innermost annotate l;;
|
