open Mlpost
open Box

(* Some custom values *)

let padding = Num.bp 15.
let delta = Num.bp 10.

let unused = "$^\\star$"
let big_title s = "\\textbf{\\Large{" ^ s ^ "}}"
let small_title s = "\\textbf{\\large{" ^ s ^ "}}"

let external_color = Color.rgb8 255 165 0
let internal_color = Color.rgb8 50 205 50
let plugin_color = Color.lightcyan
let make_color = Color.rgb8 250 128 114
let intf_color = Color.rgb8 46 139 97

(* Some very useful functions: should be in some way in the mlpost API? *)

let box_width ?name ?style ?fill ?dy w b =
  box ?name ?style ?fill ?dy ~dx:(Num.divf (Num.subn w (width b)) 2.) b

let box_height ?name ?style ?fill ?dx h b =
  box ?name ?style ?fill ?dx ~dy:(Num.divf (Num.subn h (height b)) 2.) b

let box_hw ?name ?style ?fill h b =
  box ?name ?style ?fill 
    ~dx:(Num.divf (Num.subn h (width b)) 2.)
    ~dy:(Num.divf (Num.subn h (height b)) 2.) b

let vbox_same_width ?name ?padding ~style l =
  let max = List.fold_left (fun acc b -> Num.maxn acc (width b)) Num.zero l in
  vbox ?name ?padding
    (List.map 
       (fun b -> box_width max
	  ~style
	  ?fill:(get_fill b)
	  ~dy:Num.zero 
	  (clear_stroke b))
       l)

let simulate_box ?name b = empty ?name ~width:(width b) ~height:(height b) () 

let xmed ?(coef=0.5) p1 p2 = 
  Num.multf coef (Num.addn (Point.xpart p1) (Point.xpart p2))
let ymed ?(coef=0.5) p1 p2 = 
  Num.multf coef (Num.addn (Point.ypart p1) (Point.ypart p2))
let med ?xcoef ?ycoef p1 p2 = 
  Point.pt (xmed ?coef:xcoef p1 p2, ymed ?coef:ycoef p1 p2)

(* Some special functions for this figure *)

let modul ?(color=external_color) ?same_height ?same_width s =
  let t = tex s in
  match same_height, same_width with
  | None, None -> box ~name:s ~fill:color ~style:Rect t
  | Some h, None -> box_height ~name:s ~fill:color ~style:Rect h t
  | None, Some w -> box_width ~name:s ~fill:color ~style:Rect w t
  | Some h, Some w -> 
      assert (h = w); 
      box_hw ~name:s ~fill:color ~style:Rect w t

(* The figure itself *)

let fig =

  (* special external modules: Makefile.in + Design *)
  let design = 
    rect ~fill:external_color ~name:"design"
      (vbox [ tex ("Design" ^ unused); tex "(GUI extension point)" ])
  in
  let std_modul = modul ~same_height:(height design) in

  (* empty modules *)
  let empty_modules ?(color=internal_color) () = 
    let empty_module = std_modul ~color ~same_width:(height design) "" in
    let points = tex "\\dots" in
    hbox ~padding [ empty_module; points; empty_module ]
  in

  let makein = std_modul ~color:make_color "Makefile.in" in
  let configurein = std_modul ~color:make_color "configure.in" in
  let autotools = hbox ~padding [ makein; configurein ] in

  let tests =
    round_rect ~name:"tests" ~fill:plugin_color ~dx:padding ~dy:delta
      (vbox ~padding:delta
	 [ tex (small_title "Plug-in tests suite");
	   empty_modules ~color:plugin_color () ])
  in

  let types =
    round_rect ~fill:intf_color ~dx:padding ~dy:delta
      (vbox ~padding:delta
	 [ tex (small_title ("Plug-in types" ^ unused));
	   empty_modules ~color:intf_color () ])
  in
  
  (* Plug-in implem *)
  let title = tex (small_title "Plug-in implementation") in
  let register = std_modul ~color:internal_color "Register" in
  let options = std_modul ~color:internal_color "Options" in
  let b = vbox_same_width ~padding:delta ~style:Rect [ register; options ] in
  let b = vbox ~padding:delta [ title; b; empty_modules () ] in
  let implem = 
    round_rect ~name:"implem" ~fill:internal_color ~dx:delta ~dy:delta b 
  in  

  (* Plug-in GUI *)
  let gui = tex (small_title "Plug-in GUI$^\\star$") in
  let gui = 
    round_rect ~name:"gui" ~dx:delta ~dy:(Num.addn delta (Num.divf padding 2.))
      ~fill:internal_color
      (vbox ~padding:delta [ gui; empty_modules () ]) 
  in

  (* Makefile *)
  let makefile = 
    let t = tex (small_title "Empty plug-in interface") in
    box_height
      ~name:"makefile"
      ~style:RoundRect
      ~fill:intf_color
      (Num.subn (height implem) (Num.addn (height gui) padding))
      t
  in

  (* Makefile + Plug-in GUI *)
  let right_box = 
    vbox_same_width ~name:"right" ~padding ~style:RoundRect [ makefile; gui ] 
  in

  (* left column *)
  let db_main = std_modul "Db.Main" in
  let db = std_modul "Db" in
  let journal = std_modul ("Journal" ^ unused) in
  let plugin = std_modul "Plugin" in
  let prj = std_modul ("Project" ^ unused) in
  let typ = std_modul ("Type" ^ unused) in
  let left_box = 
    vbox_same_width ~padding ~style:Rect 
      [ db; db_main; plugin; typ; journal; prj ]
  in

  (* setting the components as a matrix *)
  let figure = 
    hbox ~padding:(Num.multf 3. padding)
      [ 
	left_box;
	tabularl ~hpadding:padding ~vpadding:(Num.multf 3. padding)
	  [ 
	    [ tests; autotools ];
	    [ simulate_box ~name:"ei" implem; 
	      simulate_box ~name:"er" right_box ];
	    [ types; design ] 
	  ] 
      ]
  in
  let getf s = get s figure in

  (* add the Plug-in directory and merge it in the matrix *)
  let nwp = north_west (getf "ei") in
  let sep = south_east (getf "er") in
  let main_box = hbox ~padding [ implem; right_box ] in
  let title = tex (big_title "Plug-in directory") in
  let b = vbox ~padding:delta [ title; main_box ] in
  let directory_box = 
    let r = round_rect ~fill:plugin_color ~dx:padding ~dy:delta b in
    center (med nwp sep) r
  in

  (* caption *)
  let caption =
    tabularl ~pos:`Right ~hpadding:delta
      [
	[ tex "\\textbf{Caption:}"; empty () ];
	[ tex "$\\star$"; tex "part not covered in this tutorial" ];
	[ hbox ~padding [ empty ~name:"c1" (); empty ~name:"c2" () ]; 
	  tex "registration points through hooks" ];
	[ hbox ~padding [ empty ~name:"c3" (); empty ~name:"c4" () ];
	  tex "insertion points directly into the pointed file" ]
      ]
  in
  
  let full_box = vbox ~padding ~pos:` Right [ figure; caption ] in

  let draw_arrow ?(insert=false) l =
    let p = Path.pathp ~style:Path.jLine l in
    if insert then Arrow.simple ~color:Color.red ~pen:Pen.circle p
    else Arrow.simple p
  in
  let arrow ?insert pos src dst =
    let p1, p2 = match pos with 
      | `West ->
	  let p2 = west dst in
	  Point.pt (Point.xpart (east src), Point.ypart p2), p2
      | `East ->
	  let p2 = east dst in
	  Point.pt (Point.xpart (west src), Point.ypart p2), p2
      | `South ->
	  let p2 = south dst in
	  Point.pt (Point.xpart p2, Point.ypart (north src)), p2
      | `North -> 
	  let p2 = north dst in
	  Point.pt (Point.xpart p2, Point.ypart (south src)), p2 
    in
    draw_arrow ?insert [ p1; p2 ]
  in
  let third_arrow coef ?insert ?(yscale=1.) src dst =
    let p1 = Point.yscale (Num.bp yscale) (west src) in
    let p4 = (*east dst*) (* JS: don't know why it doesn't work *)
      Point.pt (Point.xpart (east left_box), Point.ypart (east dst)) 
    in
    let x = xmed ~coef p1 p4 in
    let p2 = Point.pt (x, Point.ypart p1) in
    let p3 = Point.pt (x, Point.ypart p4) in
    (* Why [Arrow.draw] does not provide the same result? *)
    draw_arrow ?insert [ p1; p2; p3; p4 ]
  in
  let getf s = get s full_box in
  Command.seq 
    [ 
      draw full_box; 
      draw directory_box; 
      arrow `East (getf "c1") (getf "c2");
      arrow ~insert:true `East (getf "c3") (getf "c4");
      arrow `North (get "gui" directory_box) (getf "design");
      arrow ~insert:true `West (getf "tests") (getf "Makefile.in");
      arrow ~insert:true `South directory_box (getf "Makefile.in");
      arrow ~insert:true `South directory_box (getf "configure.in");
      third_arrow ~insert:true 0.5 ~yscale:0.3 directory_box (getf "Db");
      third_arrow 0.29 (get "Options" directory_box) (getf "Plugin");
      third_arrow 0.32 (get "Register" directory_box) (getf "Db.Main");
      third_arrow 0.4 ~yscale:1.23
	(get "implem" directory_box) (getf ("Journal" ^ unused));
      third_arrow 0.4 ~yscale:1.23
	(get "implem" directory_box) (getf ("Type" ^ unused));
      third_arrow 0.55 ~yscale:1.5 directory_box (getf ("Project" ^ unused));
    ]

let _ = Metapost.emit "integrated_plugin" fig
