(* PSWriter defines PostScript output routines used by PSDVI.
   The output file consists of calls to various PostScript procedures
   defined in a header file prefixed to the output.
   Some of the PostScript procedures expect integer arguments that represent
   page positions in TeX's coordinate system.  Units are in "dots"
   (i.e., device pixels, where resolution defines the number of dots per inch).
   The origin (0,0) is a dot 1 inch in from both the top and left paper edges.
   Horizontal coordinates increase to the right and vertical coordinates
   increase down the page.  The header file contains the necessary matrix
   transformations to convert TeX coordinates back into device coordinates.
*)

#include 'globals.h';
#include 'options.h';
#include 'pswriter.h';

CONST O_RDONLY = 0;        (* SYSDEP: read-only flag for open *)
      maxrbuf = 256;

TYPE rbuf = PACKED ARRAY [1..maxrbuf] OF CHAR;

FUNCTION open (VAR path : string; flags, mode : integer) : integer;   EXTERNAL;
FUNCTION read (f : integer; VAR buf : rbuf; n : integer) : integer;   EXTERNAL;
FUNCTION close(f : integer) : integer;                                EXTERNAL;

VAR
   curh, curv,             (* for SetBitmapChar and SetPostScriptChar *)
   stringlen : INTEGER;    (* ditto; current string length *)
   pendingch : CHAR;       (* ditto; terminates current string *)

(******************************************************************************)

FUNCTION OpenOutput (name : string) : BOOLEAN;

(* Returns TRUE if given file can be opened for output. *)

BEGIN
rewrite(PSfile,name);   (* create a new file and open it for writing *)
OpenOutput := TRUE;     (* assume given file is created *)
END; (* OpenOutput *)

(******************************************************************************)

FUNCTION OutputHeader (name : string) : BOOLEAN;

(* Returns TRUE if given file can be copied to output.
   Returns FALSE if file could not be opened.
*)

VAR f, length, result, buflen : integer;   buf : rbuf;

BEGIN
(* try and open existing file for reading *)
length := Len(name);
IF length < maxstring THEN name[length] := CHR(0);   (* terminate with NULL *)
f := open(name, O_RDONLY, 0);                        (* read only *)
IF length < maxstring THEN name[length] := ' ';      (* restore space *)
IF f >= 0 THEN BEGIN
   (* copy f to PSfile *)
   REPEAT
      buflen := read(f,buf,maxrbuf);
      IF buflen > 0 THEN write(PSfile,buf:buflen);
   UNTIL buflen <= 0;
   result := close(f);
   OutputHeader := TRUE;
END
ELSE
   OutputHeader := FALSE;   (* couldn't open given file *)
END; (* OutputHeader *)

(******************************************************************************)

PROCEDURE BeginPage (DVIpage : INTEGER);

BEGIN
writeln(PSfile,DVIpage:1,' @bop0');
END; (* BeginPage *)

(******************************************************************************)

PROCEDURE NewBitmapFont (VAR fontid : string);

BEGIN
writeln(PSfile,'/',fontid:Len(fontid),' @newfont');
END; (* NewBitmapFont *)

(******************************************************************************)

PROCEDURE OutputPage (DVIpage : INTEGER);

BEGIN
writeln(PSfile,DVIpage:1,' @bop1');
END; (* OutputPage *)

(******************************************************************************)

FUNCTION OutputSpecial (VAR name : string;
                        hpos, vpos : INTEGER) : BOOLEAN;

(* Returns TRUE if given file can be copied to output.
   Returns FALSE if file could not be opened.
   name can also include a space and additional PostScript text that will
   be prefixed to the given file as a separate line.  This allows users to
   include a command like "\special{foo.ps 2 2 scale}" in their TeX source.
   name is declared to be a variable parameter for efficiency reasons.
   hpos and vpos define the page position of the \special command.
   It's a good idea to do all specials on a page BEFORE chars and rules so that
   users can do nifty things like overlaying TeX text onto a shaded box.
*)

LABEL 888, 999;

VAR f, i, j, result, buflen : INTEGER;   buf : rbuf;   fspec : string;

BEGIN
(* check name for optional space (indicating additional PostScript text) *)
i := 0;
fspec := ' ';                  (* SYSDEP: fill with spaces *)
WHILE i < maxstring DO BEGIN
   IF name[i] = ' ' THEN goto 888;
   fspec[i] := name[i];        (* extract file spec from name *)
   i := i + 1;
END;
888:
(* SYSDEP: test if i = 0 otherwise open will succeed and we'll read
   some file (fspec = all spaces) full of mildly interesting junk!
*)
IF i = 0 THEN BEGIN
   OutputSpecial := FALSE; goto 999;
END;
(* try and open existing file for reading *)
IF i < maxstring THEN fspec[i] := CHR(0);   (* terminate with NULL *)
f := open(fspec, O_RDONLY, 0);              (* read only *)
IF i < maxstring THEN fspec[i] := ' ';      (* restore space *)
IF f >= 0 THEN BEGIN
   writeln(PSfile, hpos:1, ' ', vpos:1, ' p');
   writeln(PSfile, '@bsp');
   (* use j to see if there is optional text after file name *)
   j := maxstring - 1;
   WHILE name[j] = ' ' DO j := j - 1;
   j := j + 1;
   IF i < j THEN BEGIN
      (* name[i] is first ' '; skip this and copy rest of name to output *)
      i := i + 1;
      WHILE i < j DO BEGIN
         write(PSfile,name[i]);
         i := i + 1;
      END;
      writeln(PSfile);           (* text becomes first line of file *)
   END;
   (* copy f to PSfile *)
   REPEAT
      buflen := read(f,buf,maxrbuf);
      IF buflen > 0 THEN write(PSfile,buf:buflen);
   UNTIL buflen <= 0;
   result := close(f);
   writeln(PSfile, '@esp');
   OutputSpecial := TRUE;
END
ELSE
   OutputSpecial := FALSE;     (* couldn't open given file *)
999:
END; (* OutputSpecial *)

(******************************************************************************)

PROCEDURE SaveVM (VAR fontid : string);

BEGIN
writeln(PSfile,'/',fontid:Len(fontid),' @saveVM');
END; (* SaveVM *)

(******************************************************************************)

PROCEDURE BeginPostScriptFont (VAR fontname : string;
                               scaledsize, mag : INTEGER);

(* Output PostScript code to scale and set a resident PostScript font.
   The fontname will be the name of a TFM file (beginning with psprefix value).
   This TFM name will need to be converted into a PostScript font name.
   The scaledsize and mag parameters represent the desired size of the font.
*)

BEGIN
(* sp will convert scaled points to dots *)
writeln(PSfile, scaledsize:1, ' sp ', mag:1, ' 1000 div mul ',
        fontname:Len(fontname), ' PSfont');
(* initialize some globals for first SetPostScriptChar in this font *)
curh := 999999999;
curv := 999999999;
stringlen := 0;
pendingch := '?';
END; (* BeginPostScriptFont *)

(******************************************************************************)

PROCEDURE SetPostScriptChar (ch : CHAR; hpos, vpos, pwidth : INTEGER);

(* Similar to SetBitmapChar but we cannot use RELATIVE horizontal positioning
   because the advance widths of characters in a PostScript font are not
   an integral number of dots, and we must avoid accumulated rounding errors.
*)

BEGIN
IF curv = vpos THEN BEGIN      (* don't update v position *)
   IF curh <> hpos THEN BEGIN  (* update h position *)
      stringlen := 0;
      writeln(PSfile,')',pendingch);
      write(PSfile,hpos:1,'(');
      pendingch := 'H';
   END;
END
ELSE BEGIN                     (* update h and v position *)
   IF stringlen > 0 THEN BEGIN
      stringlen := 0;
      writeln(PSfile,')',pendingch);
   END;
   write(PSfile,hpos:1,' ',vpos:1,'(');
   pendingch := 'S';
END;
IF (ch >= ' ') AND (ch < CHR(127)) THEN BEGIN
   IF (ch = '(') OR (ch = ')') OR (ch = '\') THEN   (* prefix (,),\ with \ *)
      write(PSfile,'\',ch)
   ELSE
      write(PSfile,ch);
END
ELSE
   (* put out 3 octal digits representing ch *)
   write(PSfile,'\', CHR(ORD('0') + (ORD(ch) DIV 64)),
                     CHR(ORD('0') + ((ORD(ch) DIV 8) MOD 8)),
                     CHR(ORD('0') + (ORD(ch) MOD 8)) );
(* update current page position and string length for next call *)
curh := hpos + pwidth;
curv := vpos;
stringlen := stringlen + 1;
IF (stringlen MOD 72) = 0 THEN writeln(PSfile,'\');
END; (* SetPostScriptChar *)

(******************************************************************************)

PROCEDURE BeginBitmapFont (VAR fontid : string);

BEGIN
writeln(PSfile,fontid:Len(fontid),' sf');
(* Initialize some globals for first SetBitmapChar in this font.
   This is not relevant when BeginBitmapFont is used before OutputPage.
*)
curh := 999999999;
curv := 999999999;
stringlen := 0;
pendingch := '?';
END; (* BeginBitmapFont *)

(******************************************************************************)

PROCEDURE SetBitmapChar (ch : CHAR; hpos, vpos, pwidth : INTEGER);

BEGIN
IF curv = vpos THEN BEGIN      (* don't update v position *)
   IF curh <> hpos THEN BEGIN  (* update h position (kern or space) *)
      stringlen := 0;
      writeln(PSfile,')',pendingch);
      write(PSfile,hpos-curh:1,'(');
      pendingch := 'h';
   END;
END
ELSE BEGIN                     (* update h and v position *)
   IF stringlen > 0 THEN BEGIN
      stringlen := 0;
      writeln(PSfile,')',pendingch);
   END;
   write(PSfile,hpos:1,' ',vpos:1,'(');
   pendingch := 's';
END;
IF (ch >= ' ') AND (ch < CHR(127)) THEN BEGIN
   IF (ch = '(') OR (ch = ')') OR (ch = '\') THEN   (* prefix (,),\ with \ *)
      write(PSfile,'\',ch)
   ELSE
      write(PSfile,ch);
END
ELSE
   (* put out 3 octal digits representing ch *)
   write(PSfile,'\', CHR(ORD('0') + (ORD(ch) DIV 64)),
                     CHR(ORD('0') + ((ORD(ch) DIV 8) MOD 8)),
                     CHR(ORD('0') + (ORD(ch) MOD 8)) );
(* update current page position and string length for next call *)
curh := hpos + pwidth;
curv := vpos;
stringlen := stringlen + 1;
IF (stringlen MOD 72) = 0 THEN writeln(PSfile,'\');
END; (* SetBitmapChar *)

(******************************************************************************)

PROCEDURE EndFont;

(* Terminate the last "h v(..." or "dh(..." for the current font. *)

BEGIN
IF stringlen > 0 THEN writeln(PSfile,')',pendingch);
END; (* EndFont *)

(******************************************************************************)

PROCEDURE RestoreVM;

BEGIN
writeln(PSfile,'@restoreVM');
END; (* RestoreVM *)

(******************************************************************************)

PROCEDURE SetRule (wd, ht, hpos, vpos : INTEGER);

(* Output some PostScript to set the given rule at the given position. *)

BEGIN
writeln(PSfile, wd:1, ' ', ht:1, ' ', hpos:1, ' ', vpos:1, ' r');
END; (* SetRule *)

(******************************************************************************)

PROCEDURE EndPage (DVIpage : INTEGER);

(* Output some PostScript to end the current page. *)

BEGIN
writeln(PSfile, DVIpage:1, ' @eop');
END; (* EndPage *)

(******************************************************************************)

PROCEDURE CloseOutput;

(* Output some final PostScript. *)

BEGIN
writeln(PSfile, '@end');
(* no need to close PSfile *)
END; (* CloseOutput *)