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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
(**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
type 'a t = Node of 'a * 'a t list
let rec map f (Node (x,l)) = Node (f x, List.map (map f) l)
let rec map2 f (Node (x,l1)) (Node (y,l2)) =
Node (f x y, List.map2 (map2 f) l1 l2)
let rec combine (Node (x,l1)) (Node (y,l2)) =
Node ((x,y), List.map2 combine l1 l2)
let rec split (Node ((x,y),l)) =
let l1,l2 = List.split (List.map split l) in
Node (x,l1), Node (y,l2)
let rec fold f acc (Node (x,l)) =
let acc = List.fold_left (fold f) acc l in
f acc x
let rec fold_child f acc (Node (x,l)) =
List.fold_left (fun acc (Node(y,_) as n) -> fold_child f (f acc x y) n) acc l
let filter_option f t =
let rec aux (Node (x,l)) =
match f x with
| None -> None
| Some x ->
let l = List.map aux l in
let l = List.filter (function None -> false | Some _ -> true) l in
let l = List.map (function None -> assert false | Some x -> x) l in
Some (Node (x,l)) in
match aux t with
| None -> invalid_arg "Tree_adv.filter"
| Some x -> x
let filter f t =
filter_option (fun a -> if f a then None else Some a) t
let root_map f t =
let rec aux r (Node (x,l)) = Node (f r x, List.map (aux (Some x)) l) in
aux None t
let map_children f t =
let rec aux (Node (x,l)) =
let child = List.map (function Node (x,_) -> x) l in
Node (f x child, List.map aux l) in
aux t
module Place (X : Signature.Boxlike) = struct
let gen_place ~place t =
let box_from_a z = Box.empty ~width:(X.width z) ~height:(X.height z) () in
let box_tree = map box_from_a t in
let b = place box_tree in
map2 (fun z e -> X.set_pos (Box.ctr (Box.sub e b)) z) t box_tree
let place ?(cs=Num.bp 5.) ?(ls=Num.bp 12.) ?(valign=`Center) ?(halign=`North)
t =
let rec aux (Node (x,l)) =
let l = Box.hbox ~padding:cs ~pos:halign (List.map aux l) in
Box.vbox ~padding:ls ~pos:valign [x;l] in
aux t
let place ?ls ?cs ?valign ?halign t =
gen_place ~place:(place ?ls ?cs ?valign ?halign) t
end
open Command
let draw to_box t =
fold (fun acc x -> acc ++ Box.draw (to_box x)) Command.nop t
let gen_draw_arrows default ~style ~corner t =
root_map (fun a b ->
match a with
| None -> default
| Some a -> style (corner `South a) (corner `North b)) t
let wrap_whs_box give_box mod_box f =
let width a = Box.width (give_box a) in
let height a = Box.height (give_box a) in
let set_pos p a = mod_box a (Box.center p (give_box a)) in
f ~width ~height ~set_pos
let wrap_corner_box give_box f =
let corner p a = Box.corner p (give_box a) in
f ~corner
module Overlays =
struct
type interval = | Bet of int * int (** [|a,b|] *)
| Bef of int (** ]|-oo,a|] *)
| Aft of int (** [|a,+oo|[ *)
| Nev (** emptyset *)
| Alw (** N *)
let in_interval i = function
| Bet (x,y) when x<=i && i<=y -> true
| Bef x when i<=x -> true
| Aft x when x<=i -> true
| Alw -> true
| _ -> false
let min_interval n = function
| Bet (a,_) -> min a n
| Bef a -> min a n
| Aft a -> min a n
| _ -> n
let max_interval n = function
| Bet (_,b) -> max b n
| Bef b -> max b n
| Aft b -> max b n
| _ -> n
let min_tree to_interval t =
let f n a = min_interval n (to_interval a) in
fold f max_int t
let max_tree to_interval t =
let f n a = max_interval n (to_interval a) in
fold f min_int t
type 'a spec = (interval * 'a) list
let rec assoq n = function
| [] -> raise Not_found
| (i,a)::l when in_interval n i -> a
| _::l -> assoq n l
let max to_num = function
| [] -> invalid_arg "Tree_adv.Overlays.width"
| (_,a)::l ->
List.fold_left (fun w (_,p) -> Num.maxn w (to_num p)) (to_num a) l
let set_pos sp pos =
List.map (fun (i,b) -> i,sp pos b)
end
module Overlays_Boxlike (X : Signature.Boxlike)
: Signature.Boxlike with type t = X.t Overlays.spec
=
struct
open Overlays
type t = X.t spec
let width = max X.width
let height = max X.height
let set_pos = set_pos X.set_pos
end
|
