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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
open! Core
module Make (Name : Types.Name) = struct
module Types = Types.Make (Name)
open Types
let rec replace_v (v : Value.t) ~(from : Name.t) ~(to_ : Name.t) : Value.t =
let kind =
match v.value_kind with
| Fake -> Value.Fake
| Redirect { name } ->
let name = if Name.equal name from then to_ else name in
Value.Redirect { name }
| Named n -> Named (if Name.equal n from then to_ else n)
| Singleton -> Singleton
| Mapn l -> Mapn (List.map l ~f:(replace_v ~from ~to_))
in
{ v with value_kind = kind }
and replace_c
({ kind; free_variables; here } as c : Computation.t)
~(from : Name.t)
~(to_ : Name.t)
: Computation.t
=
if not (Set.mem free_variables from)
then c
else (
let kind : Kind.t =
match kind with
| Bindings { bindings; last_body } ->
let bindings =
List.map bindings ~f:(fun binding ->
{ binding with bound = replace_c binding.bound ~from ~to_ })
in
let last_body = replace_c last_body ~from ~to_ in
Bindings { bindings; last_body }
| Value v -> Value (replace_v v ~from ~to_)
| Wrapping w ->
Wrapping { w with bodies = List.map w.bodies ~f:(replace_c ~from ~to_) }
in
let free_variables =
free_variables |> Fn.flip Set.remove from |> Fn.flip Set.add to_
in
{ kind; free_variables; here })
;;
let compare_bindings_for_sorting
{ Binding.as_ = as1; bound = { free_variables = f1; _ } }
{ Binding.as_ = as2; bound = { free_variables = f2; _ } }
=
match Name.Set.compare f1 f2 with
| 0 -> Name.compare as1 as2
| other -> other
;;
let insert groups item =
let rec find_indexes (groups : Binding.t list list) (item : Binding.t) idx acc =
match groups with
| [] -> acc
| group :: rest ->
if List.exists group ~f:(fun member ->
Set.mem member.bound.free_variables item.as_)
then acc
else find_indexes rest item (idx + 1) (idx :: acc)
in
match find_indexes groups item 0 [] with
| [] -> [ item ] :: groups
| idx :: _ ->
List.mapi groups ~f:(fun i group -> if i = idx then item :: group else group)
;;
let group_by_deps l ~last_body ~point_to =
List.fold
(List.rev l)
~init:[ [ { Binding.bound = last_body; as_ = point_to } ] ]
~f:insert
;;
let group_bindings (bindings : Binding.t list) ~curr_id ~last_body ~point_to =
let grouped = group_by_deps ~last_body ~point_to bindings in
List.rev grouped
|> List.fold
~init:([], [], Name.Set.empty, curr_id)
~f:(fun (rows, down_row, missing_one_level_down, curr_id) row ->
let provided_here = Name.Set.of_list (List.map row ~f:(fun { as_; _ } -> as_)) in
let gaps = Set.diff missing_one_level_down provided_here in
let missing_here =
Set.union
gaps
(List.fold
row
~init:Name.Set.empty
~f:(fun acc { Binding.bound = { free_variables; _ }; _ } ->
Set.union acc free_variables))
in
let rewrite, curr_id =
Set.fold gaps ~init:(Name.Map.empty, curr_id) ~f:(fun (acc, curr_id) gap ->
let name, curr_id = Name.next curr_id in
Map.set acc ~key:gap ~data:name, curr_id)
in
let down_row =
List.map down_row ~f:(fun binding ->
let bound =
Map.fold rewrite ~init:binding.Binding.bound ~f:(fun ~key ~data acc ->
replace_c acc ~from:key ~to_:data)
in
{ binding with bound })
in
let curr_id, redirections =
let rewritten = Map.to_alist rewrite in
List.fold_map rewritten ~init:curr_id ~f:(fun curr_id (from, to_) ->
let intermediate, curr_id = Name.next curr_id in
let bound_id, curr_id = Name.next curr_id in
let last_body_id, curr_id = Name.next curr_id in
let inner =
{ Binding.bound =
{ kind =
Kind.Value
{ value_kind = Value.Redirect { name = from }
; value_here = None
; value_id = bound_id
}
; free_variables = Name.Set.singleton from
; here = None
}
; as_ = intermediate
}
in
let last_body =
{ Types.Computation.kind =
Kind.Value
{ value_kind = Value.Redirect { name = intermediate }
; value_here = None
; value_id = last_body_id
}
; free_variables = Name.Set.singleton intermediate
; here = None
}
in
( curr_id
, { Binding.bound =
{ kind = Kind.Bindings { bindings = [ inner ]; last_body }
; free_variables = Name.Set.singleton from
; here = None
}
; as_ = to_
} ))
in
let this_row_including_redirections =
redirections @ row |> List.sort ~compare:compare_bindings_for_sorting
in
down_row :: rows, this_row_including_redirections, missing_here, curr_id)
|> fun (rows, last_row, _, curr_id) -> last_row :: rows, curr_id
;;
let reorder_to_minimize_crossings l =
List.folding_map l ~init:None ~f:(fun prev cur ->
match prev with
| None -> Some cur, cur
| Some prev ->
List.map cur ~f:(fun n ->
let positions =
n.Binding.bound.free_variables
|> Set.to_list
|> List.filter_map ~f:(fun free ->
List.findi prev ~f:(fun _ { Binding.as_; _ } -> Name.equal as_ free)
|> Option.map ~f:(fun (i, _) -> Float.of_int i))
in
let pos =
match List.length positions with
| 0 -> -1.0
| n -> List.sum (module Float) ~f:Fn.id positions /. Float.of_int n
in
pos, n)
|> List.sort ~compare:[%compare: float * Types.Binding.t]
|> List.map ~f:(fun (_, n) -> n)
|> fun a -> Some a, a)
;;
let organize_bindings bindings ~curr_id ~last_body ~point_to =
let grouped, curr_id = group_bindings bindings ~last_body ~point_to ~curr_id in
reorder_to_minimize_crossings grouped, curr_id
;;
end