(*     txt2ps.sml                            *)
(*     Copyright (C) 2000 Daikoku Manabu     *)
(*     Saturday, 29 January 2000             *)

fun TextToPostScript (infilename,outfilename) =
    let
        open TextIO Int
        val instr = openIn infilename
        val outstr = openOut outfilename

        val fontsize = 9
        val margin = 80
        val lineskip = 10
        val headsep = 17

        val right_margin = 595-margin
            (* 595 is A4's width. *)
        val head_y = 841-(margin+fontsize)
            (* 841 is A4's height. *)
        val origin_y = head_y-headsep

        datatype characterCode = Ascii | SjisF | SjisS
        val mode = ref Ascii
        val page = ref 1
        val line = ref origin_y
        val hexCount = ref 0

        fun outputList [] = ()
          | outputList (x::xs) = (
                output (outstr,x);
                outputList xs
            )

        fun header () =
            let
                val spage = toString (!page)
            in 
                outputList [
                    "%%Page: ", spage, " ", spage, "\n",
                    "a (", infilename, ") ts (",
                    spage, ") ps"];
                case !mode of
                    Ascii => output (outstr," a\n")
                  | _     => output (outstr," j\n")
            end

        fun prologue () = outputList [
            "%!PS-Adobe-3.0\n",
            "%%EndComments\n",
            "\n",
            "/courier /Courier findfont ",
            toString fontsize,
            " scalefont def\n",
            "/minchou /Ryumin-Light-83pv-RKSJ-H findfont ",
            toString fontsize,
            " scalefont def\n",
            "/a { courier setfont } def\n",
            "/j { minchou setfont } def\n",
            "/m { ",
            toString margin,
            " exch moveto } def\n",
            "/s { show } def\n",
            "/ts { ",
            toString margin, " ",
            toString head_y,
            " moveto show } def\n",
            "/ps {\n",
            "    ", toString right_margin, " ",
            toString head_y, " moveto \n",
            "    dup stringwidth pop neg 0 rmoveto show\n",
            "} def\n",
            "\n"
        ]

        fun epilogue () = outputList [
            case !mode of
                Ascii => ")"
              | _     => ">",
            " s\n\n",
            "%%EOF\n\n"
        ]

        fun prefix y = (
            outputList [toString y, " m"];
            case !mode of
                Ascii => output (outstr," (")
              | _     => output (outstr," <")
        )

        fun pageClear () = (
            output (outstr,"showpage\n\n");
            if not (endOfStream instr) then (
                page := !page + 1;
                header ();
                line := origin_y
            ) else ()
        )

        fun lineBreak () = (
            line := !line - lineskip;
            case !mode of
                Ascii => output (outstr,") s\n")
              | _     => output (outstr,"> s\n");
            if !line<margin then pageClear ()
            else ();
            prefix (!line);
            hexCount := 0
        )

        fun outputAscii c =
            case c of
                #"(" => output (outstr,"\\(")
              | #")" => output (outstr,"\\)")
              | #"\\" => output (outstr,"\\\\")
              | _ => output1 (outstr,c)

        fun outputHex c =
            output (outstr,fmt StringCvt.HEX (ord c))

        fun outputSjisFirst c = (
            hexCount := !hexCount + 1;
            if !hexCount>10 then (
                hexCount := 1;
                output (outstr,"> s\n<")
            ) else ();
            if !hexCount>1 then
                output1 (outstr,#" ")
            else ();
            outputHex c
        )

        fun isSjisFirst c =
            let
                val cn = ord c
            in
                       (cn>=0x81 andalso cn<=0x9f)
                orelse (cn>=0xe0 andalso cn<=0xfc)
            end

        fun outputCharacter c =
            if c = #"\n" then lineBreak ()
            else
                case !mode of
                    Ascii =>
                        if isSjisFirst c then (
                            mode := SjisF;
                            output (outstr,") s\nj <");
                            outputHex c;
                            hexCount := 1
                        ) else
                            outputAscii c
                  | SjisF => (
                        mode := SjisS;
                        outputHex c
                    )
                  | _     =>
                        if isSjisFirst c then (
                            mode := SjisF;
                            outputSjisFirst c
                        ) else (
                            mode := Ascii;
                            output (outstr,"> s\na (");
                            outputAscii c
                        )

        val cr = ref #" "
    in
        prologue ();
        header ();
        prefix origin_y;
        while not (endOfStream instr) do (
            cr := valOf (input1 instr);
            outputCharacter (!cr)
        );
        epilogue ();
        closeIn instr;
        closeOut outstr
    end