open Mlpost
(* Helpers *)
let tex = Box.tex ~dx:(Num.cm 0.2) ~dy:(Num.cm 0.2)
let tex_list = List.map tex
let darkred = Color.rgb8 102 0 0
let darkgreen = Color.rgb8 0 102 0
let cells_of_tab g =
let lines = Box.elts g in
Array.map Box.elts lines
let middle p1 p2 =
let p = Point.add p1 p2 in
Point.mult (Num.of_float 0.5) p
let last_upper_cell cells = cells.(0).((Array.length cells.(0)) - 1)
(* Boxes *)
let hpadding = Num.cm 1.25
let vpadding = Num.cm 0.55
let place_languages languages =
let tex_languages f = tex_list (List.map f languages) in
let f_reg s = "$" ^ s ^ "$" in
let f_lab s = "$\\Labelled{" ^ s ^ "}$" in
let languages = tex_languages f_reg in
let lab_languages = tex_languages f_lab in
Box.tabularl ~stroke:None ~hpadding ~vpadding [lab_languages ; languages]
(* Arrows *)
let line_arrows color line =
let n = Array.length line in
let rec aux i =
if i >= n-1 then []
else
let p1 = Box.east line.(i) in
let p2 = Box.west line.(i+1) in
(Arrow.simple ~color (Path.pathp [p1 ; p2])) :: (aux (i+1))
in
List.map Box.pic (aux 0)
let delta = 0.1
let shift_r = Point.pt (Num.cm delta, Num.zero)
let shift_l = Point.pt (Num.cm (-.delta), Num.zero)
let erasure_arrows cells =
let n = Array.length cells.(0) in
let rec aux i =
if i >= n then []
else
let p1 = Box.south cells.(0).(i) in
let p2 = Box.north cells.(1).(i) in
(Arrow.simple ~color:darkgreen (Path.pathp [p1 ; p2])) :: (aux (i+1))
in
let arrows = List.map Box.pic (aux 0) in
(Box.shift shift_r (List.hd arrows)) :: (List.tl arrows)
let labelling_arrow cells =
let p1 = Box.north cells.(1).(0) in
let p2 = Box.south cells.(0).(0) in
let arrow = Box.pic (Arrow.simple ~color:Color.blue (Path.pathp [p1 ; p2])) in
Box.shift shift_l arrow
let add_arrows cells =
let arrows1 = line_arrows darkred cells.(0) in
let arrows2 = line_arrows Color.red cells.(1) in
let arrows3 = erasure_arrows cells in
let lab_arrow = labelling_arrow cells in
lab_arrow :: (arrows1 @ arrows2 @ arrows3)
(* Instrumentation *)
let place_res cells =
let res = cells.(1).(0) in
let res = Box.place `North ~pos:`South ~padding:vpadding cells.(0).(0) res in
res
let place_cost_deduction res cells =
let cost_deduction = tex "$\\mathcal{L} \\rightarrow \\N$" in
let first_cell = cells.(0).(0) in
let last_cell = last_upper_cell cells in
let x = Point.xpart (Box.east last_cell) in
let x = Num.addn x (Num.multf 0.5 hpadding) in
let y = Point.ypart (middle (Box.south res) (Box.north first_cell)) in
let target = Box.center (Point.pt (x, y)) (Box.empty ()) in
let cost_deduction = Box.place `Center ~pos:`West target cost_deduction in
cost_deduction
let arrow_instrument res cost_deduction cells =
let p1 = Box.north cells.(0).(0) in
let p2 = Box.south res in
let arrow1 = Arrow.simple ~color:Color.magenta (Path.pathp [p1 ; p2]) in
let p1 = Box.west cost_deduction in
let p2 = Point.pt (Point.xpart p2, Point.ypart p1) in
let arrow2 = Path.draw ~color:Color.magenta (Path.pathp [p1 ; p2]) in
let arrows = [arrow1 ; arrow2] in
Box.group (List.map Box.pic arrows)
let arrow_cost_deduction cost_deduction cells =
let last_cell = last_upper_cell cells in
let p1 = Box.east last_cell in
let p3 = Box.south cost_deduction in
let p2 = Point.pt (Point.xpart p3, Point.ypart p1) in
let path = Path.pathp ~style:Path.jLine [p1 ; p2 ; p3] in
let color = Color.orange in
let head = Arrow.head_triangle_full ~color in
let kind = Arrow.add_head ~head (Arrow.add_line ~color Arrow.empty) in
(* let tex = "\\textcolor{orange}{$\\kappa$}" in *)
Box.pic (Arrow.draw ~kind ~anchor:`South (* ~tex *) path)
let instrument cells =
let res = place_res cells in
let cost_deduction = place_cost_deduction res cells in
let arrow1 = arrow_instrument res cost_deduction cells in
let arrow2 = arrow_cost_deduction cost_deduction cells in
Box.group [res ; cost_deduction ; arrow1 ; arrow2]
(* Diagram *)
let diagram instrumentation languages =
let b = place_languages languages in
let cells = cells_of_tab b in
let arrows = add_arrows cells in
let instrumentation =
if instrumentation then instrument cells else Box.empty () in
Box.group (b :: instrumentation :: arrows)
(* Main *)
let result1 = diagram false ["\\Imp" ; "\\VM" ; "\\ASM"]
let result2 = diagram true ["\\Imp" ; "\\VM" ; "\\ASM"]
let result3 = diagram true ["\\Clight" ; "\\Cminor" ; "..." ; "\\ASM"]
(* Output pictures *)
let results = [result1 ; result2 ; result3]
let results = List.map Box.draw results
let iteri f =
let rec aux i = function
| [] -> []
| e :: l -> f i e ; aux (i+1) l
in
aux 1
let _ =
iteri (fun i b -> Metapost.emit ("diagram" ^ (string_of_int i)) b) results