(***********************************************************************)
(*                                                                     *)
(*                             Active-DVI                              *)
(*                                                                     *)
(*                   Projet Cristal, INRIA Rocquencourt                *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Lesser General Public License.          *)
(*                                                                     *)
(*  Jun Furuse, Didier Rémy and Pierre Weis.                           *)
(*  Contributions by Roberto Di Cosmo, Didier Le Botlan,               *)
(*  Xavier Leroy, and Alan Schmitt.                                    *)
(*                                                                     *)
(*  Based on Mldvi by Alexandre Miquel.                                *)
(***********************************************************************)

(* $Id: gs.ml,v 1.41 2004/07/16 07:51:35 weis Exp $ *)

let debugs = Misc.debug_endline;;

let get_do_ps, set_do_ps, init_do_ps =
 let has_to_do_ps = ref !Global_options.pson in
 (fun () -> !has_to_do_ps),
 (fun b -> has_to_do_ps := b),
 (fun () -> has_to_do_ps := !Global_options.pson);;

let antialias =
  Options.flag false
    "-A"
    "  ask Active-DVI to use PostScript antialiasing,\
    \n\t (the default is not to use PostScript antialiasing).";;

let pstricks =
  Options.flag false
    "-pstricks"
    "  ask Active-DVI to show moveto,\
    \n\t (the default is not to show moveto).";;

let showps_ref = ref false;;
let showps s =
  if !showps_ref then (print_endline  (Printf.sprintf "%s" s));;

(* (Printf.sprintf "SHOWPS: %s" s));;*)

Options.add
  "--showps" (Arg.Set showps_ref)
  "  ask advi to print to stdout a copy\
  \n\t of the PostScript program sent to gs.";;

let pspage = ref 0;;

(* constants *)
(** ack_string is an arbitrary string that would not be ``naturally''
   generated by gs. Xdvi used characters \347\310\376 in octet which is
   \231\200\254 in decimal.
   I don't know why... to test whether gs is new or old *)
let ack_string = "\231\200\254\n";;
let pos_string = "dvi";;
let err_string = "Error:";;
let current_x = ref 0;;
let current_y = ref 0;;

let parse_pos s =
  let c = String.index s ',' in
  let bc = s.[3] in
  (* y comes first, then x *)
  let y = String.sub s 3 (c - 3) in
  let x = String.sub s (c + 1) (String.length s - c - 1) in
  Misc.round (float_of_string x), Misc.round (float_of_string y);;

let ack_request =
  String.concat ""
    [ "flushpage ("; ack_string; ") print flush "; ];;

let timeout = 3.;;

exception Timeout;;
exception Error;;

exception Terminated;;
exception Retry;;

let x11alpha = "x11alpha";;
let x11 = "x11";;
type graphical =
    { display : int;
      window  : int32 (* GraphicsY11.window_id *) ; (* Window identifier. *)
      pixmap  : int32 (* GraphicsY11.window_id *) ; (* Pixmap identifier. *)
      width  : int ; (* geometry of the window. *)
      height : int ;
      bwidth  : int ; (* geometry of the backing store. *)
      bheight : int ;
      xdpi : float ; (* x resolution *)
      ydpi : float ; (* y resolution *)
      x    : int   ; (* x offset in pixels
                          (coordinates of the upper left corner) *)
      y    : int   ; (* y offset *)
    };;

exception Killed of string;;

let rec select fd_in fd_out fd_exn timeout =
  (* dirty hack: Graphics uses itimer internally! *)
  let start = Unix.gettimeofday () in
  try
    Unix.select fd_in fd_out fd_exn timeout
  with
    Unix.Unix_error (Unix.EINTR, _, _) as exn ->
      let now = Unix.gettimeofday () in
      let remaining = start +. timeout -. now in
      if remaining > 0.0 then select fd_in fd_out fd_exn timeout else [], [], []
;;

class gs () =
  let _ = GraphicsY11.window_id() in
  let gr = {
      display = 0;
      window = GraphicsY11.window_id ();
      pixmap = GraphicsY11.bstore_id ();
      width = Graphics.size_x ();
      height = Graphics.size_y ();
      bwidth = GraphicsY11.bsize_x ();
      bheight = GraphicsY11.bsize_y ();
      xdpi = 72.0;
      ydpi = 72.0;
      x = 0;
      y = 0;
    } in
  let dpi = 72 (* unite utilise par dvi? *) in
  let command = Config.gs_path in
  let command_args =
    [|
      command; 
      "-dNOPLATFONTS"; "-dNOPAUSE";
      "-sDEVICE=" ^ (if !antialias then x11alpha else x11);
      "-q";
      "-dSAFER";
      "-";
    |] in

  let _ = debugs command;
  Array.iter debugs command_args in

  (* Set environment so that ghostscript writes in our window. *)
  let _ =
    Unix.putenv "GHOSTVIEW"
      (if Global_options.get_global_display_mode ()
       then Printf.sprintf "%lu " gr.window
       else Printf.sprintf "%lu %lu " gr.window gr.pixmap) in

  let iof = Misc.round and foi = float_of_int in
  let lx = iof ( (foi (gr.x * dpi)) /. gr.xdpi)
  and ly = iof ( (foi (gr.y * dpi)) /. gr.ydpi)
  and ux = iof ( (foi ((gr.x + gr.bwidth)  * dpi)) /. gr.xdpi )
  and uy = iof ( (foi ((gr.y + gr.bheight) * dpi)) /. gr.ydpi) in

  (* Set ghostscript property. *)
  let content =
    Printf.sprintf "%s %d %d %d %d %d %f %f %d %d %d %d"
      "0" (* no backing pixmap for the window *)
      0   (* Rotation : 0 90 180 270 *)
      lx ly ux uy
      (* lower-left x y, upper-right x y :
         Bounding box in default user coordinates. *)
      gr.xdpi gr.ydpi (* Resolution x y. *)
      0 0 0 0 (* Margins left, bottom, top, right. *) in

  let _ =
    begin
      try GraphicsY11.set_named_atom_property  "GHOSTVIEW" content;
      with x -> Misc.fatal_error "Cannot set ``GHOSTVIEW'' property"
    end;
  (* Ignore signal SIGPIPE. *)
  Unix.sigprocmask Unix.SIG_BLOCK [ Sys.sigpipe ] in

  let lpd_in, lpd_out = Unix.pipe () in
  let rpd_in, rpd_out = Unix.pipe () in
  let leftout = Unix.out_channel_of_descr lpd_out in
  let rightin = Unix.in_channel_of_descr rpd_in in
  let close_all () =
    let tryc f x = try f x with _ -> () in
    tryc close_out leftout;
    tryc close_in rightin;
    tryc Unix.close lpd_in;
    tryc Unix.close rpd_in in
  let pid =
    Unix.create_process command command_args lpd_in rpd_out
      (* Unix.stdout *) Unix.stderr
  in
  object (self)
    val pid = pid
    val mutable ack = 0
    method gr = gr

    method ack_request =
      try
        ack <- ack + 1;
        self # line ack_request;
        flush leftout;
        self # ack;
      with
      | Killed s ->
          self # kill;
          Misc.warning s;
          raise Terminated
      | exn ->
          Misc.warning (Printexc.to_string exn);
          self # kill; 
          raise Terminated

    method ack =
      if ack > 0 then
        begin
          let s =
            try input_line rightin
            with End_of_file ->
              match select [ rpd_in ] [] [] 1.0 with
              | [], _, _ ->
                  begin match Unix.waitpid [ Unix.WNOHANG ] pid with
                  | x, Unix.WEXITED y when x > 0 ->
                      raise (Killed "gs exited")
                  | 0, _ ->
                      raise (Killed "gs alive but not responding")
                  | _, _ ->
                      raise (Killed "gs in strange state")
                  end
              | _, _, _ ->
                  input_line rightin in
          if Misc.has_prefix s ack_string then ack <- ack - 1 else
          if Misc.has_prefix pos_string s then
            begin
              try
                let x, y = parse_pos s in
                current_x := x; current_y := y
              with
              | Not_found | Failure _ -> Misc.warning s
            end else
          if Misc.has_prefix err_string s then
            begin
              Misc.warning s;
              raise (Killed "Error in Postscript");
            end else
          Misc.warning s;
          self # ack
        end;

    method kill =
      try
        Unix.kill pid Sys.sighup;  (* Sys.sigkill? *)
        let _, _ = Unix.waitpid [] pid in
        close_all ();
      with Unix.Unix_error (_, _, _) -> ()

    method line l =
      try
        showps l;
        output_string leftout l;
        output_char leftout '\n';
      with exc ->
        Misc.warning (Printexc.to_string exc);
        self # kill;
        Misc.warning "GS Terminated"

    method sync =
      try self # ack_request;
      with
        Killed s ->
          self # kill;
          set_do_ps false;
          Misc.warning (Printf.sprintf "%s\nContinuing without gs\n" s)

    method ps b =
      List.iter self#line b;

  end;;

let advi_pro =
"/advi@floatstring 20 string def
/advi@printfloat { advi@floatstring cvs print } def
/advi@CP {
CM [1 0 0 -1 0 0] setmatrix
    CP (dvi) print advi@printfloat  (,) print advi@printfloat (\n) print 
setmatrix } def";;
let advi_noshowpage = " /showpage { } /def"
let advi_resetmatrix = "[1 0 0 -1 0 0] concat"

type special = Unprotected | Protected | Begin | Continue | End 

let texbegin = "TeXDict begin";;
let texend = "flushpage end";;
let moveto x y =
  (*   current_x := x; current_y := y; *)
  Printf.sprintf "%d %d moveto" x y
;;

let make_header (b, h) =
  if b then
    String.concat "\n"
      [ "TeXDict begin @defspecial";
        h;
        "@fedspecial end"; ]
  else String.concat "" [ "("; h; ") run" ];;

let texc_special_pro gv =
  let l = [ "texc.pro"; "special.pro" ] in
  try
    let l' = Search.true_file_names [] l in
    if List.length l = List.length l' then
      List.map (fun s -> make_header (false, s)) l'
    else raise Not_found
  with
    Not_found ->
      Misc.warning "Cannot find Postscript prologues: texc.pro or special.pro";
      Misc.warning "Continuing without Postscript specials";
      gv # kill;
      set_do_ps false;
      [];;

class gv =
  object (self)
    val mutable dirtypage = true
    val mutable process : gs option = None
    val mutable dpi = 72
    val mutable mag = 1.
    val mutable xorig = 0
    val mutable yorig = 0
    val mutable sync = true
    val mutable headers = []
    method line =
      try
        self # process # line
      with Terminated ->
        process <- None;
        raise Terminated
    method moveto x y =
      let x' = x + xorig in
      let y' = y - yorig  in
      moveto x' y'

    method current_point =
      let x' = !current_x in
      let y' = !current_y + (self # process # gr).height in
      x', y'

    method check_size =
      begin
        match process with
        | None -> ()
        | Some gs ->
            let gr = gs # gr in
            let size_x = GraphicsY11.bsize_x () in
            let size_y = GraphicsY11.bsize_y () in
            if size_x <> gr.bwidth || size_y <> gr.bheight
            then self # kill;
      end;

    method sync =
      if not sync then
        begin
          match process with
          | Some p -> p # sync; sync <- true
          | None -> ()
        end

    method add_headers l =
      if headers = [] then headers <- texc_special_pro self;
      let l = List.map make_header l in
      match
        List.filter 
          (function s -> List.for_all (function s' -> s <> s') headers)
          l
      with
      | [] -> ()
      | l ->
          headers <- headers @ l;
          match process with
          | Some gs ->
              gs # line "grestore SI restore";
              List.iter (gs # line) l;
              (* to avoid no-current-point *)
              gs # line "0 0 moveto";
              gs # line "/SI save def gsave";
          | None -> ()

    method newpage l sdpi m x y =
      self # check_size;
      let l = List.map make_header l in
      let l = List.filter (fun s -> not (List.mem s headers)) l in
      let gs = self # process in
      if l <> [] then headers <- headers @ l;
      dpi <- sdpi;
      mag <- m;
      xorig <- x;
      yorig <- (gs # gr).height - y;
      if !pspage > 0 then showps "showpage";
      incr pspage;
      showps (Printf.sprintf "%%%%Page: %d %d\n" !pspage !pspage);
      gs # line "\n%% Newpage\n";
      gs # line "grestore";
      gs # line "0 0 moveto";
      if l <> [] then gs # line "SI restore";
      gs # line
        (Printf.sprintf
           "TeXDict begin %d %d div dup /Resolution X /VResolution X end"
           dpi dpi);
      gs # line
        (Printf.sprintf
           "TeXDict begin /DVImag %f def end"
           mag);
      List.iter gs # line l;
      if l <> [] then gs # line  "/SI save def";
      gs # line "gsave";
      gs # sync


    method process =
      match process with
      | None ->
          if not (get_do_ps ()) then raise Terminated;
          let gs = new gs () in
          if headers = [] then headers <-  texc_special_pro self;
          (* should take matrix as a parameter ? *)
          showps "%!PS-Adobe-2.0\n%%Creator: Active-DVI\n%!";
          gs # line "[1 0 0 -1 0 0] concat";
          List.iter (gs # line) headers;
          gs # line advi_pro;
          gs # line "TeXDict begin @landscape end";
          gs # line "/SI save def gsave";
          process <- Some gs;
          gs
      | Some gs ->
(*prerr_endline (Printf.sprintf "Calling existing gs interpreter");*)
          gs

    method send b  =
(*prerr_endline (Printf.sprintf "Calling gv#SEND with\n\t\t %s" (String.concat " " b));*)
      self # check_size;
      self # process # ps b;
      sync <- false

    method def (b : string) =
      (* insert into postscript into user dictionnary, typically with '!'
         should not change graphic parameters *)
      (* does not draw---no flushpage *)
      (* in fact b should have already be loaded through *)
      self # send [ ]

    method ps action b (x : int) (y : int) =
      (* prerr_endline (Printf.sprintf "Calling gv#PS with\n\t\t %s" b); *)
      self # send
        begin match action with
        | Unprotected ->
            (* insert non protected postscript, typically with ``ps:''
               may (not ?) change graphic parameters;
               still need to set current point for initclip PStrick specials.
             *)
            [ texbegin; self # moveto x y; b; texend ];
        | Protected ->
            (* insert protected postscript, typically with '"'
               does (?) change graphic parameters *)
            [ texbegin;
              self # moveto x y;
              "@beginspecial @setspecial";
              b;
              "@endspecial"; texend;
            ] ;
        | Begin ->
            (* Open SDict as @beginspecial
               but do not reset graphical parameters *)
            [ texbegin; 
              self # moveto x y;
              "@defspecial"; 
              b ];
        | Continue -> 
            (* Continue [in SDict] *)
            [ b ];
        | End -> 
            (* Close SDict *)
            [ "@fedspecial"; texend; ];
        end; 
      sync <- false

    method file name (llx, lly, urx, ury) (rwi, rhi : int * int) x y =
      (* insert into postscript into user dictionnary, typically with '!'
         should not change graphic parameters *)
      (* does not draw---no flushpage *)
      let ri z s = if z <> 0 then Printf.sprintf "%d %s" z s else "" in
      self # send [ texbegin;
                    self # moveto x y;
                    "@beginspecial";
                    Printf.sprintf "%d @llx %d @lly %d @urx %d @ury"
                      llx lly urx ury;
                    ri rwi "@rwi"; ri rhi "@rhi";
                    "@setspecial";
                    Printf.sprintf"(%s) run" name;
                    "@endspecial";
                    texend;
                  ] ;
      sync <- false

    method kill =
      showps "showpage";
      match process with
      | None -> ()
      | Some gs ->
          gs # kill;
          process <- None
  end
;;

let gv = new gv;;

(* exported functions *)

let kill () = gv # kill;;

let ps_forms =
  [ 
    "ps: ", Unprotected;
    "\" ", Protected;
    "ps::[begin]", Begin;
    "ps::[end]", End;
    "ps::", Continue;
    "ps:", Unprotected;
   ];;

let draw s x y =
  if get_do_ps () then
    let pred (prefix, action) =
      try gv#ps action (Misc.get_suffix prefix s) x y; true
      with Misc.Match -> false in
    if not (List.exists pred ps_forms) then
      try gv#ps Protected (Misc.get_suffix  "\" " s) x y with Misc.Match ->
        try gv#def (Misc.get_suffix  "! " s) with Misc.Match -> 
(*
   | Misc.Match ->
   try gv#file (Misc.get_suffix  "psfile: " s) bbox size x y with
 *)
          Misc.warning
            (Printf.sprintf "Unknown PostScript commands\n\t\t %s" s)
;;
let draw_file fname bbox ri x y =
  if get_do_ps () then gv#file fname bbox ri x y;;

let current_point() =
    gv#current_point;;

let add_headers x =
  gv#add_headers x;;

let newpage x =
  gv#newpage x;;

let flush () =
  if get_do_ps () then
    try  gv#sync
    with
    | Terminated ->
        Misc.warning "Continuing without Postscript";
        gv#kill;
        set_do_ps false;;

let toggle_antialiasing () =
  antialias := not !antialias;
  kill ();;