source: Deliverables/Dissemination/final-review/wp5/Pics/diagram.ml @ 3282

Last change on this file since 3282 was 3282, checked in by regisgia, 7 years ago
  • WP5 slides for the final review.
File size: 4.7 KB
Line 
1
2open Mlpost
3
4
5(* Helpers *)
6
7let tex = Box.tex ~dx:(Num.cm 0.2) ~dy:(Num.cm 0.2)
8let tex_list = List.map tex
9
10let darkred = Color.rgb8 102 0 0
11let darkgreen = Color.rgb8 0 102 0
12
13let cells_of_tab g =
14  let lines = Box.elts g in
15  Array.map Box.elts lines
16
17let middle p1 p2 =
18  let p = Point.add p1 p2 in
19  Point.mult (Num.of_float 0.5) p
20
21let last_upper_cell cells = cells.(0).((Array.length cells.(0)) - 1)
22
23
24(* Boxes *)
25
26let hpadding = Num.cm 1.25
27let vpadding = Num.cm 0.55
28
29let place_languages languages =
30  let tex_languages f = tex_list (List.map f languages) in
31  let f_reg s = "$" ^ s ^ "$" in
32  let f_lab s = "$\\Labelled{" ^ s ^ "}$" in
33  let languages = tex_languages f_reg in
34  let lab_languages = tex_languages f_lab in
35  Box.tabularl ~stroke:None ~hpadding ~vpadding [lab_languages ; languages]
36
37
38(* Arrows *)
39
40let line_arrows color line =
41  let n = Array.length line in
42  let rec aux i =
43    if i >= n-1 then []
44    else
45      let p1 = Box.east line.(i) in
46      let p2 = Box.west line.(i+1) in
47      (Arrow.simple ~color (Path.pathp [p1 ; p2])) :: (aux (i+1))
48  in
49  List.map Box.pic (aux 0)
50
51let delta = 0.1
52let shift_r = Point.pt (Num.cm delta, Num.zero)
53let shift_l = Point.pt (Num.cm (-.delta), Num.zero)
54
55let erasure_arrows cells =
56  let n = Array.length cells.(0) in
57  let rec aux i =
58    if i >= n then []
59    else
60      let p1 = Box.south cells.(0).(i) in
61      let p2 = Box.north cells.(1).(i) in
62      (Arrow.simple ~color:darkgreen (Path.pathp [p1 ; p2])) :: (aux (i+1))
63  in
64  let arrows = List.map Box.pic (aux 0) in
65  (Box.shift shift_r (List.hd arrows)) :: (List.tl arrows)
66
67let labelling_arrow cells =
68  let p1 = Box.north cells.(1).(0) in
69  let p2 = Box.south cells.(0).(0) in
70  let arrow = Box.pic (Arrow.simple ~color:Color.blue (Path.pathp [p1 ; p2])) in
71  Box.shift shift_l arrow
72
73let add_arrows cells =
74  let arrows1 = line_arrows darkred cells.(0) in
75  let arrows2 = line_arrows Color.red cells.(1) in
76  let arrows3 = erasure_arrows cells in
77  let lab_arrow = labelling_arrow cells in
78  lab_arrow :: (arrows1 @ arrows2 @ arrows3)
79
80
81(* Instrumentation *)
82
83let place_res cells = 
84  let res = cells.(1).(0) in
85  let res = Box.place `North ~pos:`South ~padding:vpadding cells.(0).(0) res in
86  res
87
88let place_cost_deduction res cells =
89  let cost_deduction = tex "$\\mathcal{L} \\rightarrow \\N$" in
90  let first_cell = cells.(0).(0) in
91  let last_cell = last_upper_cell cells in
92  let x = Point.xpart (Box.east last_cell) in
93  let x = Num.addn x (Num.multf 0.5 hpadding) in
94  let y = Point.ypart (middle (Box.south res) (Box.north first_cell)) in
95  let target = Box.center (Point.pt (x, y)) (Box.empty ()) in
96  let cost_deduction = Box.place `Center ~pos:`West target cost_deduction in
97  cost_deduction
98
99let arrow_instrument res cost_deduction cells =
100  let p1 = Box.north cells.(0).(0) in
101  let p2 = Box.south res in
102  let arrow1 = Arrow.simple ~color:Color.magenta (Path.pathp [p1 ; p2]) in
103  let p1 = Box.west cost_deduction in
104  let p2 = Point.pt (Point.xpart p2, Point.ypart p1) in
105  let arrow2 = Path.draw ~color:Color.magenta (Path.pathp [p1 ; p2]) in
106  let arrows = [arrow1 ; arrow2] in
107  Box.group (List.map Box.pic arrows)
108
109let arrow_cost_deduction cost_deduction cells =
110  let last_cell = last_upper_cell cells in
111  let p1 = Box.east last_cell in
112  let p3 = Box.south cost_deduction in
113  let p2 = Point.pt (Point.xpart p3, Point.ypart p1) in
114  let path = Path.pathp ~style:Path.jLine [p1 ; p2 ; p3] in
115  let color = Color.orange in
116  let head = Arrow.head_triangle_full ~color in
117  let kind = Arrow.add_head ~head (Arrow.add_line ~color Arrow.empty) in
118  (* let tex = "\\textcolor{orange}{$\\kappa$}" in *)
119  Box.pic (Arrow.draw ~kind ~anchor:`South (* ~tex *) path)
120
121let instrument cells =
122  let res = place_res cells in
123  let cost_deduction = place_cost_deduction res cells in
124  let arrow1 = arrow_instrument res cost_deduction cells in
125  let arrow2 = arrow_cost_deduction cost_deduction cells in
126  Box.group [res ; cost_deduction ; arrow1 ; arrow2]
127
128(* Diagram *)
129
130let diagram instrumentation languages =
131  let b = place_languages languages in
132  let cells = cells_of_tab b in
133  let arrows = add_arrows cells in
134  let instrumentation =
135    if instrumentation then instrument cells else Box.empty () in
136  Box.group (b :: instrumentation :: arrows)
137
138
139(* Main *)
140
141let result1 = diagram false ["\\Imp" ; "\\VM" ; "\\ASM"]
142
143let result2 = diagram true ["\\Imp" ; "\\VM" ; "\\ASM"]
144
145let result3 = diagram true ["\\Clight" ; "\\Cminor" ; "..." ; "\\ASM"]
146
147
148(* Output pictures *)
149
150let results = [result1 ; result2 ; result3]
151let results = List.map Box.draw results
152
153let iteri f =
154  let rec aux i = function
155    | [] -> []
156    | e :: l -> f i e ; aux (i+1) l
157  in
158  aux 1
159
160let _ =
161  iteri (fun i b -> Metapost.emit ("diagram" ^ (string_of_int i)) b) results
Note: See TracBrowser for help on using the repository browser.