(**************************************************************************)
(*                                                                        *)
(*  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
open Concrete_types

let fprintf = Printf.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 a < 0.0001 then fprintf fmt "0"
  else if a >= 1.e04 then fprintf fmt "%.4f" f
  else Printf.fprintf fmt "%.4g" 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 " "


type specials_env =
  { externalimages : (string * Matrix.t,int) Hashtbl.t;
    colors         : (P.color,int) Hashtbl.t;
    count          : int ref}

let new_specials_env () =
  {externalimages = Hashtbl.create 7;
   colors         = Hashtbl.create 17;
   count          = ref 0}

module MPS = struct

  type line_cap =
    | ButtCap
    | RoundCap
    | SquareCap

  type line_join =
    | MiterJoin
    | RoundJoin
    | BevelJoin

  let moveto_float fmt x y = fprintf fmt "%a %a moveto" float x float y
  let lineto_float fmt x y = fprintf fmt "%a %a lineto" float x float y
  let rlineto_float fmt x y = fprintf fmt "%a %a rlineto" float x float y
  let lineto fmt p = lineto_float fmt p.x p.y
  let moveto fmt p = moveto_float fmt p.x p.y
  let rlineto fmt p = rlineto_float fmt p.x p.y
  let lineto_floatp fmt (x,y) = lineto_float fmt x y

  let curveto fmt p1 p2 p3 =
    fprintf fmt "%a %a %a %a %a %a curveto"
      float p1.x float p1.y float p2.x float p2.y float p3.x float p3.y

  let close_path fmt = fprintf fmt "close_path"
  let newpath fmt = fprintf fmt "newpath"
  let stroke fmt = fprintf fmt "stroke"
  let fill fmt = fprintf fmt "fill"
  let showpage fmt = fprintf fmt "showpage"
  let clip fmt = fprintf fmt "clip"

  let gsave fmt = fprintf fmt "gsave"
  let grestore fmt = fprintf fmt "grestore"

  let setlinewidth fmt f =
    (** strange treatment of linewidth of Metapost *)
   fprintf fmt "0 %a dtransform truncate idtransform setlinewidth pop" float f

  let setlinecap fmt c =
    let i =
      match c with
      | ButtCap -> 0
      | RoundCap -> 1
      | SquareCap -> 2 in
    fprintf fmt "%d setlinecap" i

  let setlinejoin fmt j =
    let i =
      match j with
      | MiterJoin -> 0
      | RoundJoin -> 1
      | BevelJoin -> 2 in
    fprintf fmt "%d setlinejoin" i

  let matrix fmt t =
    fprintf fmt "[%a %a %a %a %a %a]"
      float t.xx float t.yx float t.xy float t.yy float t.x0 float t.y0

  let transform fmt t =
    if t = Matrix.identity then () else fprintf fmt "%a concat" matrix t

  let scolor_rgb fmt r g b =
    fprintf fmt "%a %a %a setrgbcolor" float r float g float b

  let scolor_cmyk fmt c m y k =
    fprintf fmt "%a %a %a %a setcmykcolor" float c float m float y float k

  let scolor_gray fmt c = fprintf fmt "%a setgray" 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 _ ->
      (* harvest take care of that case *)
      assert false

  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 _ -> assert false
    | Dviinterp.Gray g -> scolor_gray fmt g

  let dash fmt (offset,pattern) =
    fprintf fmt "[%a ] %a setdash"
      (list space float) pattern
      float offset

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

  let glyph fmt cl font =
    fprintf fmt "(%a) %s %a fshow" (list nothing char_const) cl
      (Fonts.tex_name font) float (Fonts.scale font conversion)

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

  let rectangle fmt p w h =
    fprintf fmt "%t %a %a %a %a %t %t"
      newpath
      moveto p
      lineto_floatp (p.x+.w, p.y)
      lineto_floatp (p.x+.w, p.y+.h)
      lineto_floatp (p.x, p.y+.h)
      close_path
      fill

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

let in_context fmt f = fprintf fmt "%t %t %t" MPS.gsave f MPS.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 = x ; y = y } in
  in_context fmt (fun _ ->
    fprintf fmt "%a %a %a"
      MPS.transform trans
      MPS.dvi_color i.Dviinterp.color
      MPS.rectanglep (p,w,h)
  )

let draw_char fmt 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 %a"
      MPS.transform trans
      MPS.dvi_color text.Dviinterp.tex_info.Dviinterp.color
      MPS.moveto p
      MPS.glyphp (text.tex_string, text.tex_font)
  )

(* FIXME why do we need to negate y coordinates? *)
let tex_cmd fmt 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 trans text
  | Dviinterp.Specials _ -> ()
  | Dviinterp.Draw_text_type1 _ -> assert false

let draw_tex fmt t =
  list space (fun fmt x -> tex_cmd fmt 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 MPS.lineto fmt sd
  else MPS.curveto fmt sb sc sd

let path =
  let rec path fmt = function
    | S.Path p ->
        begin match p.S.pl with
        | [] -> assert false
        | (x::_) as l ->
            fprintf fmt "%a %a"
              MPS.moveto (Spline.left_point x)
              (list space curveto) l
        end ;
        if p.S.cycle then begin fprintf fmt " %t" MPS.close_path end
    | S.Point p ->
        fprintf fmt "%a %a"
          MPS.moveto p
          MPS.rlineto p in
  fun fmt p ->
    fprintf fmt "%t %a"
      MPS.newpath
      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 *)
  MPS.setlinewidth fmt t.xx

let specials_signal = 0.123
let specials_division = 1000.


(** map real color to encoded color :
    - identity for four first case
    - encoding for transparency
    - encoding specials rgb opaque color
*)
let add_color_se clr se =
  match clr with
    | None -> clr
    | Some OPAQUE Gray _ -> clr
    | Some OPAQUE CMYK _ -> clr
    | Some OPAQUE RGB (r,_,_) when r <> specials_signal -> clr
    | Some clr ->
      let nb =
        try
          Hashtbl.find se.colors clr
        with Not_found ->
          incr se.count;
          let nb = !(se.count) in
          Hashtbl.add se.colors clr nb;
          nb
      in
      let nb = (float_of_int nb) /. specials_division in
      Some (OPAQUE (RGB (specials_signal,0.003,nb)))



let add_image_se =
  let dumb_path = Spline_lib.create_lines
    [Point_lib.zero;Point_lib.zero;
     Point_lib.zero;Point_lib.zero] in
  let dumb_path = Spline_lib.close dumb_path in
fun p se ->
  let nb =
    try
      Hashtbl.find se.externalimages p
    with Not_found ->
        incr se.count;
      let nb = !(se.count) in
      Hashtbl.add se.externalimages p nb; nb in
  (* 0.010? *)
  let nb = (float_of_int nb) /. specials_division in
  let c = Some (OPAQUE (RGB (specials_signal,0.019,nb))) in
  P.Fill_path(dumb_path,c)


let rec harvest se = function
  | P.Empty as p -> p
  | P.OnTop l ->
    let add acc e =
      let p = harvest se e in
      if p = P.Empty then acc else p::acc in
    let l = List.fold_left add [] l in
    if l = [] then P.Empty else P.OnTop (List.rev l)
  | P.Stroke_path(p,c,d,e) -> P.Stroke_path(p,add_color_se c se,d,e)
  | P.Fill_path (p,c) -> P.Fill_path (p,add_color_se c se)
  | P.Tex _ as p -> p
  | P.Transform (m,t) -> harvest se (P.apply_transform_cmds m t)
  | P.Clip (com,p) ->
    let com = harvest se com in
    if com = P.Empty then com else P.Clip (com,p)
  | P.ExternalImage (f,h,m) -> add_image_se (f,m) se


(*
For specials in mps
The specials are described at the bottom of the preamble
The first line describe the version, the special signal and the special_div
%%MetaPostSpecials: 2.0 123 1000
The next describe specials : length data special_number special_type
%%MetaPostSpecial: 7 1 0.5 1 0 0 1 3
Color cmyk  : 7 (cmyk_counter)                       c m y k special_number 1
Color spot  :                                                               2
Color rgba  : 7 mode_transparency value_transparency r g b   special_number 3
Color cmyka : 8 mode_transparency value_transparency c m y k special_number 4
Color spota : 8 mode_transparency value_transparency ? ? ? ? special_number 5

In the text they appear as color :
  special_signal (1 cmyk 2 spot 3 rgb) special_number
 0.123 0.003 0.001 setrgbcolor

*)

let print_specials_color =
  let pr_color fmt c =
    match c with
    | RGB (r,b,g) -> fprintf fmt "%f %f %f" r g b
    | Gray g -> fprintf fmt "%f %f %f" g g g
    | CMYK (c,m,y,k) -> fprintf fmt "%f %f %f %f" c m y k in
  fun fmt cl id ->
    let trans, c =
      match cl with
      | OPAQUE c -> 1., c
      | TRANSPARENT (a,c) -> a, c in
    let mode, special_type =
      match c with
      | RGB _ | Gray _ -> 7, 3
      | CMYK _ -> 8, 4 in
    fprintf fmt "%%%%MetaPostSpecial: ";
    fprintf fmt "%i 1 %f %a %i %i\n" mode trans pr_color c id special_type

let print_specials_extimg fmt (f,m) id =
  fprintf fmt
    "%%%%MetaPostSpecial: 9 %f %f %f %f %f %f %s %i 10\n"
    m.xx m.yx m.xy m.yy m.x0 m.y0 f id

let print_specials fmt cx =
  let se = new_specials_env () in
  let cx = harvest se cx in
  if Hashtbl.length se.colors <> 0 || Hashtbl.length se.externalimages <> 0
  then begin
    fprintf fmt "%%%%MetaPostSpecials: 2.0 %i %i\n"
      (int_of_float (specials_signal *. specials_division))
      (int_of_float specials_division);
    Hashtbl.iter (print_specials_color fmt) se.colors;
    Hashtbl.iter (print_specials_extimg fmt) se.externalimages
  end;
  cx


let rec picture fmt p =
  match p with
  | P.Empty -> ()
  | P.OnTop l -> list space picture fmt l
  | P.Stroke_path(pa,clr,pe,da) ->
      in_context fmt (fun _ ->
        fprintf fmt "%a%a%a %a %t\n"
          (option space MPS.color) clr
          (option space MPS.dash) da
          pen pe
          path pa
          MPS.stroke)
  | P.Fill_path (p,clr)->
      in_context fmt (fun _ ->
        fprintf fmt "%a %a %t\n"
          (option space MPS.color) clr
          path p
          MPS.fill)
  | P.Tex t -> draw_tex fmt t
  | P.Clip (com,p) ->
      in_context fmt (fun _ ->
        fprintf fmt "%a %t %a"
          path p
          MPS.clip
          picture com
      )
  | P.Transform _
  | P.ExternalImage _ -> assert false



module BitMap = struct
  (* FIXME replace me by something more efficient *)

  (* encode our bitmap as a string (array of chars) *)
  type t = string
  (* a char '0' corresponds to '0', a char '1' corresponds to '1' *)

  let mk n = String.make n '0'

  let set t n = t.[n] <- '1'
  let get t n = t.[n]
  let min t =
    try String.index t '1' with Not_found -> assert false

  let safe_sub_four s i =
    (* if the string does not have 4 remaining chars, pad with zeros *)
    let my_len = 4 in
    let l = String.length s in
    if i + my_len <= l then String.sub s i my_len
    else
      let buf = String.make my_len '0' in
      for j = i to l - 1 do
        buf.[j-i] <- s.[j]
      done;
      buf

  let one_char t i =
    match safe_sub_four t i with
    | "0000" -> '0'
    | "0001" -> '1'
    | "0010" -> '2'
    | "0011" -> '3'
    | "0100" -> '4'
    | "0101" -> '5'
    | "0110" -> '6'
    | "0111" -> '7'
    | "1000" -> '8'
    | "1001" -> '9'
    | "1010" -> 'a'
    | "1011" -> 'b'
    | "1100" -> 'c'
    | "1101" -> 'd'
    | "1110" -> 'e'
    | "1111" -> 'f'
    | _ -> assert false

  let chars t =
    let b = Buffer.create 5 in
    let rec aux k =
      let c = one_char t k in
      if c = '0' then Buffer.contents b
      else begin
        Buffer.add_char b c;
        aux (k+4)
      end in
    let m = min t in
    Printf.sprintf "%x:%s" m (aux m)

end

(* FIXME do better than comparing font names *)
module FontCmp = struct
  type t = Fonts.t
  let compare a b = String.compare (Fonts.tex_name a) (Fonts.tex_name b)
end
(* module FS = Set.Make(FontCmp) *)
module FM = Map.Make(FontCmp)

let max_char f =
  (Fonts.metric f).Tfm.file_hdr.Tfm.ec

let fonts p =
  let x = ref FM.empty in
  Picture_lib.iter (fun p ->
    match p with
    | P.Tex g ->
        List.iter (fun c ->
          match c with
          | Draw_text text ->
              let f = text.tex_font in
              let map =
                try FM.find f  !x
                with Not_found ->
                  let map = BitMap.mk (max_char f) in
                  x := FM.add f map !x;
                  map in
              List.iter (fun x ->
                BitMap.set map (Int32.to_int x)) text.tex_string
          | _ -> ()) g.Gentex.tex
    | _ -> ()) p;
  !x


(* Following the dvips manual, for example on
 http://www.radicaleye.com/dvipsman/dvips.html#SEC34,
 the Font line looks as follows:
 %*Font: tfmname scaledbp designbp hex-start:hex-bitstring
 Here is the meaning of each of these elements:

tfmname
    The TeX TFM filename, e.g., `cmr10'. You can give the same tfmname on more
    than one `%*Font' line; this is useful when the number of characters from
    the font used needs a longer hex-bitstring (see item below) than
    conveniently fits on one line.
scaledbp
    The size at which you are using the font, in PostScript points (TeX big
    points). 72bp = 72.27pt = 1in.
designbp
    The designsize of the font, again in PostScript points. This should match
    the value in the TFM file tfmname. Thus, for `cmr10', it should be
    `9.96265'.
hex-start
    The character code of the first character used from the font, specified as
    two ASCII hexadecimal characters, e.g., `4b' or `4B' for `K'.
hex-bitstring
    An arbitrary number of ASCII hexadecimal digits specifying which characters
    following (and including) hex-start are used. This is treated as a bitmap.
    For example, if your figure used the single letter `K', you would use
    `4b:8' for hex-start and hex-bitstring. If it used `KLMNP', you would use
    `4b:f4'.
 *)
let fontdecl fmt f map =
  let n = Fonts.tex_name f in
  let d = Fonts.design_size f in
  let r = point_of_cm (Fonts.ratio_cm f) in
  let magic_string = BitMap.chars map in
  fprintf fmt "%%*Font: %s %f %f %s\n" n d r magic_string

let draw fmt x =
  let {x = minx; y = miny},{x = maxx; y = maxy} = Picture_lib.bounding_box x in
  let minxt, minyt, maxxt, maxyt =
    floor minx, floor miny, ceil maxx, ceil maxy in
  fprintf fmt "%%!PS\n";
  fprintf fmt "%%%%BoundingBox: %f %f %f %f\n" minxt minyt maxxt maxyt;
  fprintf fmt "%%%%HiResBoundingBox: %f %f %f %f\n" minx miny maxx maxy;
  fprintf fmt "%%%%Creator: Mlpost %s\n" Version.version;
  (** metapost add a creation date but it breaks determinism *)
  (* fprintf fmt "%%%%CreationDate: %s\n" (Misc.date_string ()); *)
  fprintf fmt "%%%%Pages: 1\n";
  FM.iter (fontdecl fmt) (fonts x);
  fprintf fmt "%%%%BeginProlog\n";
  fprintf fmt "%%%%EndProlog\n";
  fprintf fmt "%%%%Page: 1 1\n";
  let cx = print_specials fmt (P.content x) in
  fprintf fmt "%a %a %a %a %t"
    MPS.setlinewidth (P.default_line_size /.2.)
    MPS.setlinecap MPS.RoundCap
    MPS.setlinejoin MPS.RoundJoin
    picture cx
    MPS.showpage;
  fprintf fmt "\n%%%%EOF\n"

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

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

let generate figs = ignore (mps figs)
