(**************************************************************************)
(*                                                                        *)
(*  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.                  *)
(*                                                                        *)
(**************************************************************************)

open Point_lib
open Matrix
module P = Picture_lib
module S = Spline_lib
open Dviinterp

let fprintf = Format.fprintf

let conversion = 0.3937 *. 72.

let point_of_cm cm = conversion *. cm

let float fmt f =
  (* PDF does not understand e notation, so we protect the printf which
     uses %g in the cases where this would use e notation; we do not need that
     much precision anyway*)
  let a = abs_float f in
  if classify_float f = FP_nan then
    (* should be an error there is a bug somewhere to track *)
    fprintf fmt "0"
  else if a < 0.0001 then fprintf fmt "0"
  else if a >= 1.e04 then fprintf fmt "%.4f" f
  else fprintf fmt "%.4g" f

let bp fmt f = Format.fprintf fmt "%a bp" float f

let rec list sep p fmt l =
  match l with
  | [] -> ()
  | [ x ] -> p fmt x
  | x :: xs ->
      p fmt x;
      sep fmt;
      list sep p fmt xs

let option sep p fmt o =
  match o with
  | None -> ()
  | Some x ->
      p fmt x;
      sep fmt

let nothing _ = ()

let space fmt = fprintf fmt "@ "

let braces p fmt x = fprintf fmt "{%a}" p x

module PGF = struct
  type line_cap = ButtCap | RoundCap | SquareCap

  let _ = ButtCap

  let _ = SquareCap

  type line_join = MiterJoin | RoundJoin | BevelJoin

  let _ = MiterJoin

  let _ = BevelJoin

  let point fmt p = fprintf fmt "\\pgfqpoint{%a}{%a}" bp p.x bp p.y

  let moveto fmt p = fprintf fmt "\\pgfpathmoveto{%a}" point p

  let lineto fmt p = fprintf fmt "\\pgfpathlineto{%a}" point p

  let curveto fmt p1 p2 p3 =
    fprintf fmt "\\pgfpathcurveto{%a}{%a}{%a}" point p1 point p2 point p3

  let close_path fmt = fprintf fmt "\\pgfpathclose"

  let stroke fmt = fprintf fmt "\\pgfusepath{stroke}"

  let fill fmt = fprintf fmt "\\pgfusepath{fill}"

  let clip fmt = fprintf fmt "\\pgfusepath{clip}"

  let gsave fmt = fprintf fmt "\\begin{pgfscope}"

  let grestore fmt = fprintf fmt "\\end{pgfscope}"

  let setlinewidth fmt f =
    (* handle strange treatment of linewidth of Metapost *)
    fprintf fmt "\\pgfsetlinewidth{%a}" bp f

  let setlinecap fmt c =
    let i =
      match c with
      | ButtCap -> "butt"
      | RoundCap -> "round"
      | SquareCap -> "rect"
    in
    fprintf fmt "\\pgfset%scap" i

  let setlinejoin fmt j =
    let i =
      match j with
      | MiterJoin -> "miter"
      | RoundJoin -> "round"
      | BevelJoin -> "bevel"
    in
    fprintf fmt "\\pgfset%sjoin" i

  let transform fmt t =
    if t = Matrix.identity then ()
    else
      fprintf fmt "\\pgflowlevel{\\pgftransformcm{%a}{%a}{%a}{%a}{%a}}" float
        t.xx float t.yx float t.xy float t.yy point { x = t.x0; y = t.y0 }

  let scolor_rgb fmt r g b =
    fprintf fmt "\\color[rgb]{%a,%a,%a}" float r float g float b

  let scolor_cmyk fmt c m y k =
    fprintf fmt "\\color[cmyk]{%a,%a,%a,%a}" float c float m float y float k

  let scolor_hsb fmt h s b =
    fprintf fmt "\\color[hsb]{%a,%a,%a}" float h float s float b

  let scolor_gray fmt c = fprintf fmt "\\color[gray]{%a}" float c

  let scolor fmt c =
    match c with
    | Concrete_types.RGB (r, g, b) -> scolor_rgb fmt r g b
    | Concrete_types.CMYK (c, m, y, k) -> scolor_cmyk fmt c m y k
    | Concrete_types.Gray c -> scolor_gray fmt c

  let color fmt c =
    match c with
    | Concrete_types.OPAQUE c -> scolor fmt c
    | Concrete_types.TRANSPARENT (f,c) ->
      fprintf fmt "\\pgfsetfillopacity{%a}\\pgfsetstrokeopacity{%a}%a" float f float f scolor c

  let dvi_color fmt c =
    match c with
    | Dviinterp.RGB (r, g, b) -> scolor_rgb fmt r g b
    | Dviinterp.CMYK (c, m, y, k) -> scolor_cmyk fmt c m y k
    | Dviinterp.HSB (h, s, b) -> scolor_hsb fmt h s b
    | Dviinterp.Gray g -> scolor_gray fmt g

  let dash fmt (offset, pattern) =
    fprintf fmt "\\pgfsetdash{%a}{%a}"
      (list nothing (braces bp))
      pattern bp offset

  let char_const fmt c = fprintf fmt "\\char'%03lo" c

  type db = (string*float,string) Hashtbl.t

  let rec name_of_int acc i =
    let c = Char.chr (Char.code 'A' + (i mod 26)) in
    let acc = ((String.make 1 c ) ^ acc) in
    let i = i / 26 in
    if i = 0 then acc else name_of_int acc (i-1)

  let key_of_font font = ((Fonts.tex_name font),(Fonts.scale font conversion))

  let add_tex_name (db:db) font =
    let k = key_of_font font in
    if not (Hashtbl.mem db k) then
      Hashtbl.add db k (name_of_int "" (Hashtbl.length db))

  let declare_fonts fmt db =
    Hashtbl.iter (fun (name,size) id -> fprintf fmt
                     "\\font\\mlpostfont%s=%s at %apt@ "
                     id
                     name float size) db

  let glyph fmt db p cl font =
    let id = Hashtbl.find db (key_of_font font) in
    fprintf fmt
      "\\pgftext[base,left,at={%a}]{{\\mlpostfont%s %a}}"
      point p id
      (list nothing char_const) cl

  let glyphp db p fmt (cl, font) = glyph fmt db p cl font

  let rectangle fmt p w h =
    fprintf fmt "\\pgfpathrectangle{%a}{%a} %t" point p point { x = w; y = h }
      fill

  let rectanglep fmt (p, w, h) = rectangle fmt p w h
end

let in_context fmt f =
  fprintf fmt "@[<v>%t@, @[<v>%t@]@,%t@]" PGF.gsave f PGF.grestore

let fill_rect fmt trans i x y w h =
  let x = point_of_cm x
  and y = point_of_cm y
  and w = point_of_cm w
  and h = point_of_cm h in
  let p = { x; y } in
  in_context fmt (fun _ ->
      fprintf fmt "%a@ %a@ %a" PGF.transform trans PGF.dvi_color
        i.Dviinterp.color PGF.rectanglep (p, w, h))

let draw_char fmt db trans text =
  (* FIXME why do we need to negate y coordinates? *)
  let f1, f2 = text.tex_pos in
  let f1 = point_of_cm f1 and f2 = point_of_cm f2 in
  let p = { x = f1; y = -. f2 } in
  in_context fmt (fun _ ->
      fprintf fmt "%a@ %a@ %a" PGF.transform trans PGF.dvi_color
        text.Dviinterp.tex_info.Dviinterp.color (PGF.glyphp db p)
        (text.tex_string, text.tex_font))

(* FIXME why do we need to negate y coordinates? *)
let tex_cmd fmt db trans c =
  match c with
  | Dviinterp.Fill_rect (i, x, y, w, h) -> fill_rect fmt trans i x (-.y) w h
  | Dviinterp.Draw_text text -> draw_char fmt db trans text
  | Dviinterp.Specials _ -> ()
  | Dviinterp.Draw_text_type1 _ -> assert false

let draw_tex fmt db t =
  list space (fun fmt x -> tex_cmd fmt db t.Gentex.trans x) fmt t.Gentex.tex

let curveto fmt s =
  let sa, sb, sc, sd = Spline.explode s in
  if sa = sb && sc = sd then PGF.lineto fmt sd else PGF.curveto fmt sb sc sd

let path =
  let path fmt = function
    | S.Path p ->
        ( match p.S.pl with
        | [] -> assert false
        | x :: _ as l ->
            fprintf fmt "%a@ %a" PGF.moveto (Spline.left_point x)
              (list space curveto) l );
        if p.S.cycle then fprintf fmt " %t" PGF.close_path
    | S.Point p -> fprintf fmt "%a@ %a" PGF.moveto p PGF.lineto p
  in
  fun fmt p -> fprintf fmt "%a" path p

let pen fmt t =
  (* FIXME do something better *)
  (* for now assume that the pen is simply a scaled circle, so just grab the xx
   * value of the matrix and use that as linewidth *)
  PGF.setlinewidth fmt t.xx

let rec picture db fmt p =
  match p with
  | P.Empty -> ()
  | P.OnTop l -> list space (picture db) fmt l
  | P.Stroke_path (pa, clr, pe, da) ->
      in_context fmt (fun _ ->
          fprintf fmt "%a%a%a@ %a@ %t\n" (option space PGF.color) clr
            (option space PGF.dash) da pen pe path pa PGF.stroke)
  | P.Fill_path (p, clr) ->
      in_context fmt (fun _ ->
          fprintf fmt "%a%a@ %t\n" (option space PGF.color) clr path p PGF.fill)
  | P.Tex t -> draw_tex fmt db t
  | P.Clip (com, p) ->
      in_context fmt (fun _ ->
          fprintf fmt "%a@ %t@ %a" path p PGF.clip (picture db) com)
  | P.Transform (t, p) ->
      in_context fmt (fun _ -> fprintf fmt "%a@ %a" PGF.transform t (picture db) p)
  | P.ExternalImage (f, _, t) ->
      in_context fmt (fun _ ->
          fprintf fmt "%a@ \\pgftext{\\includegraphics{%s}}" PGF.transform t f)

let rec compute_fonts db p =
  match p with
  | P.Empty -> ()
  | P.OnTop l -> List.iter (compute_fonts db) l
  | P.Stroke_path _ -> ()
  | P.Fill_path _ -> ()
  | P.Tex t ->
    List.iter (function
  | Dviinterp.Fill_rect _ -> ()
  | Dviinterp.Draw_text text -> PGF.add_tex_name db text.tex_font
  | Dviinterp.Specials _ -> ()
  | Dviinterp.Draw_text_type1 _ -> assert false
      ) t.Gentex.tex
  | P.Clip (com, _) -> compute_fonts db com
  | P.Transform (_, p) -> compute_fonts db p
  | P.ExternalImage _ -> ()

let draw fmt x =
  let fmt = Format.formatter_of_out_channel fmt in
  let db = (Hashtbl.create 10)  in
  compute_fonts db (P.content x);
  let p1, p2 = Picture_lib.bounding_box x in
  fprintf fmt "%%%%Creator: Mlpost %s@." Mlpost_version.version;
  fprintf fmt "\\begin{tikzpicture}@.";
  fprintf fmt "\\useasboundingbox (%a, %a) rectangle (%a, %a);@." bp p1.x bp
    p1.y bp p2.x bp p2.y;
  in_context fmt (fun _ ->
      fprintf fmt "%a@ %a@ %a@ %a@ %a" PGF.setlinewidth
        (P.default_line_size /. 2.)
        PGF.setlinecap PGF.RoundCap PGF.setlinejoin PGF.RoundJoin
        PGF.declare_fonts db
        (picture db) (P.content x));
  fprintf fmt "@.\\end{tikzpicture}@."

let generate_one fn fig =
  File.write_to fn (fun fmt ->
      let fig = Compute.commandpic fig in
      (*     Format.printf "picturelib code: \n %a@." P.Print.pic fig; *)
      draw fmt fig);
  fn

let pgf figl =
  List.map
    (fun (fn, fig) ->
      let fn = File.mk fn "pgf" in
      (*     Format.printf "metapost code:\n %a@."Print.commandpic fig; *)
      generate_one fn fig)
    figl

let dump () = ignore (pgf (Defaults.emited ()))

let generate figs = ignore (pgf figs)
