IMPLEMENTATION MODULE PSWriter;

(* Author:         Andrew Trevorrow
   Implementation: University of Hamburg Modula-2 under VAX/VMS version 4
   Date Started:   August, 1986

   Description:
   PostScript output routines used by PSDVI.
   The output file consists of calls to various PostScript procedures
   defined in a header file that must be prepended 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 must contain the necessary matrix
   transformations to convert TeX coordinates back into device coordinates.

   Revised:
   November, 1987 (while at The Open University)
 - Output file is now normal text file rather than fixed-length record file.
 - Added SaveVM and RestoreVM routines to support the conserveVM flag
   used by the main module.
 - Added SetPostScriptChar to overcome rounding problems if we try to
   use SetBitmapChar for a PostScript font.

   June--August, 1988 (while at Aston University)
 - Modified SetPostScriptChar to output strings like SetBitmapChar.
 - EndBitmapFont now called EndFont as it is used for both font types.

   September--October, 1989 (while at Aston University, 2nd time)
 - Modified SendBitmapChar and SetPostScriptChar so they can't create
   a string too long for WriteChar's output buffer.
   Adrian Clark can now use his half-tone font with PSPRINT.
*)

FROM FileSystem IMPORT
   File, Create, Open, Done,
   ReadChar, WriteChar,
   Eof, Close;

CONST
   NULL = 0C;
   CR   = 15C;
   DEL  = 177C;

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

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

PROCEDURE OpenOutput (name : ARRAY OF CHAR) : BOOLEAN;

BEGIN
(* SYSDEP: create a normal VAX/VMS text file *)
Create(PSfile,name,TRUE,TRUE);
RETURN Done();
END OpenOutput;

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

PROCEDURE OutputHeader (name : ARRAY OF CHAR) : BOOLEAN;

VAR f : File;   ch : CHAR;

BEGIN
Open(f,name,FALSE);       (* SYSDEP: read only *)
IF Done() THEN
   LOOP
      ReadChar(f,ch);     (* next char or Eof *)
      IF Eof(f) THEN
         EXIT;
      ELSE
         Put(ch);         (* copy verbatim, including any ctrl chars *)
      END;
   END;
   Close(f);
   RETURN TRUE;
ELSE
   RETURN FALSE;          (* couldn't open given file *)
END;
END OutputHeader;

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

PROCEDURE BeginPage (DVIpage : CARDINAL);

BEGIN
PutCard(DVIpage); PutString(' @bop0'); Put(CR);
END BeginPage;

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

PROCEDURE NewBitmapFont (VAR fontid : ARRAY OF CHAR);

BEGIN
Put('/'); PutString(fontid); PutString(' @newfont'); Put(CR);
END NewBitmapFont;

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

PROCEDURE OutputPage (DVIpage : CARDINAL);

BEGIN
PutCard(DVIpage); PutString(' @bop1'); Put(CR);
END OutputPage;

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

PROCEDURE OutputSpecial (VAR name : specialstring;
                         hpos, vpos : INTEGER) : BOOLEAN;

VAR f : File;   fspec : specialstring;   ch : CHAR;   i : CARDINAL;

BEGIN
(* check name for optional space (indicating additional PostScript text) *)
i := 0;
fspec := '';                (* SYSDEP: fill with NULLs *)
WHILE (i <= HIGH(name)) AND (name[i] <> ' ') DO
   fspec[i] := name[i];     (* extract file spec from name *)
   INC(i);
END;
Open(f,fspec,FALSE);        (* SYSDEP: read only *)
IF Done() THEN
   PutInt(hpos); Put(' '); PutInt(vpos); PutString(' p'); Put(CR);
   PutString('@bsp'); Put(CR);
   IF i <= HIGH(name) THEN
      (* name[i] is first ' '; skip this and copy rest of name to output *)
      INC(i);
      WHILE (i <= HIGH(name)) AND (name[i] <> NULL) DO
         Put(name[i]);
         INC(i);
      END;
      Put(CR);              (* text becomes first line of file *)
   END;
   LOOP
      ReadChar(f,ch);       (* next char or Eof *)
      IF Eof(f) THEN
         EXIT;
      ELSE
         Put(ch);           (* copy verbatim, including any ctrl chars *)
      END;
   END;
   Close(f);
   PutString('@esp'); Put(CR);
   RETURN TRUE;
ELSE
   RETURN FALSE;            (* couldn't open given file *)
END;
END OutputSpecial;

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

PROCEDURE SaveVM (VAR fontid : ARRAY OF CHAR);

BEGIN
Put('/'); PutString(fontid); PutString(' @saveVM'); Put(CR);
END SaveVM;

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

PROCEDURE BeginPostScriptFont (VAR fontname : ARRAY OF CHAR;
                               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 *)
PutInt(scaledsize);  PutString(' sp ');
PutInt(mag);         PutString(' 1000 div mul ');
PutString(fontname); PutString(' PSfont'); Put(CR);
(* initialize some globals for first SetPostScriptChar in this font *)
curh := MAX(INTEGER);
curv := MAX(INTEGER);
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            (* don't update v position *)
   IF curh <> hpos THEN        (* update h position *)
      stringlen := 0;
      Put(')'); Put(pendingch); Put(CR);
      PutInt(hpos); Put('(');
      pendingch := 'H';
   END;
ELSE                           (* update h and v position *)
   IF stringlen > 0 THEN
      stringlen := 0;
      Put(')'); Put(pendingch); Put(CR);
   END;
   PutInt(hpos); Put(' '); PutInt(vpos); Put('(');
   pendingch := 'S';
END;
IF (ch >= ' ') AND (ch < DEL) THEN
   IF (ch = '(') OR (ch = ')') OR (ch = '\') THEN   (* prefix (,),\ with \ *)
      Put('\'); Put(ch);
   ELSE
      Put(ch);
   END;
ELSE
   Put('\');
   (* and put out 3 octal digits representing ch *)
   Put( CHR(ORD('0') + (ORD(ch) DIV 64)) );
   Put( CHR(ORD('0') + ((ORD(ch) DIV 8) MOD 8)) );
   Put( CHR(ORD('0') + (ORD(ch) MOD 8)) );
END;
(* update current page position and string length for next call *)
curh := hpos + pwidth;
curv := vpos;
INC(stringlen);
IF (stringlen MOD 72) = 0 THEN Put('\'); Put(CR) END;
END SetPostScriptChar;

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

PROCEDURE BeginBitmapFont (VAR fontid : ARRAY OF CHAR);

BEGIN
PutString(fontid); PutString(' sf'); Put(CR);
(* Initialize some globals for first SetBitmapChar in this font.
   This is not relevant when BeginBitmapFont is used before OutputPage.
*)
curh := MAX(INTEGER);
curv := MAX(INTEGER);
stringlen := 0;
pendingch := '?';
END BeginBitmapFont;

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

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

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

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

PROCEDURE EndFont;

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

BEGIN
IF stringlen > 0 THEN
   Put(')'); Put(pendingch); Put(CR);
END;
END EndFont;

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

PROCEDURE RestoreVM;

BEGIN
PutString('@restoreVM'); Put(CR);
END RestoreVM;

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

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

BEGIN
PutCard(wd); Put(' '); PutCard(ht); Put(' ');
PutInt(hpos); Put(' '); PutInt(vpos);
PutString(' r'); Put(CR);
END SetRule;

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

PROCEDURE EndPage (DVIpage : CARDINAL);

BEGIN
PutCard(DVIpage); PutString(' @eop'); Put(CR);
END EndPage;

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

PROCEDURE CloseOutput;

BEGIN
PutString('@end'); Put(CR);
Close(PSfile);
END CloseOutput;

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

PROCEDURE Put (ch : CHAR);

BEGIN
WriteChar(PSfile,ch);
END Put;

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

PROCEDURE PutString (s : ARRAY OF CHAR);

VAR i : INTEGER;

BEGIN
(* SYSDEP: LEN assumes end of string is first NULL, or string is full *)
FOR i := 0 TO LEN(s) - 1 DO
   WriteChar(PSfile,s[i]);
END;
END PutString;

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

PROCEDURE PutInt (i : INTEGER);

(* We call PutCard after writing any '-' sign. *)

BEGIN
IF i < 0 THEN
   WriteChar(PSfile,'-');
   i := ABS(i);
END;
PutCard(CARDINAL(i));
END PutInt;

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

PROCEDURE PutCard (c : CARDINAL);

(* Since the majority of given values will be < 10,000 we avoid
   recursion until c >= 10,000.
*)

BEGIN
IF c < 10 THEN
   WriteChar(PSfile, CHR(ORD('0') + c) );
ELSIF c < 100 THEN
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 10)) );    c := c MOD 10;
   WriteChar(PSfile, CHR(ORD('0') + c) );
ELSIF c < 1000 THEN
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 100)) );   c := c MOD 100;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 10)) );    c := c MOD 10;
   WriteChar(PSfile, CHR(ORD('0') + c) );
ELSIF c < 10000 THEN
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 1000)) );  c := c MOD 1000;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 100)) );   c := c MOD 100;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 10)) );    c := c MOD 10;
   WriteChar(PSfile, CHR(ORD('0') + c) );
ELSE
   PutCard(c DIV 10000);   (* recursive if c >= 10000 *)
   c := c MOD 10000;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 1000)) );  c := c MOD 1000;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 100)) );   c := c MOD 100;
   WriteChar(PSfile, CHR(ORD('0') + (c DIV 10)) );    c := c MOD 10;
   WriteChar(PSfile, CHR(ORD('0') + c) );
END;
END PutCard;

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

BEGIN
END PSWriter.