C     VICEtoPS Copyright 2004 Paul David Buchan (pdbuchan@yahoo.com)
C
C     This program simulates Commodore (tm) dot-matrix printers
C     by generating a PostScript file that can be printed on
C     most modern PostScript-enabled printers. VICEtoPS takes as
C     input the printer output file from the VICE (www.viceteam.org)
C     Commodore emulator.
C
C     This program is free software; you can redistribute it and/or modify
C     it under the terms of the GNU General Public License as published by
C     the Free Software Foundation; either version 2 of the License, or
C     (at your option) any later version.
C
C     This program is distributed in the hope that it will be useful,
C     but WITHOUT ANY WARRANTY; without even the implied warranty of
C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C     GNU General Public License for more details.
C
C     You should have received a copy of the GNU General Public License
C     along with this program; if not, write to the Free Software
C     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

C     NOTE: If at runtime an error occurs reporting a failed attempt to
C           access a non-existent record in the character file, try
C           compiling with "-assume byterecl". For example, with a Linux
C           Intel compiler:
C                  ifort -assume byterecl vicetops.f
C           The reason for this error is that some compilers assume a
C           record length of 4 bytes, while others assume 1 byte. For
C           gfortran on Ubuntu, this compiler flag is not necessary
C           since it assumes 1 byte record length.

      integer c, dec, i, m, nchar, row, col, offset, p(8)
      integer xmin, maxchar, ymax, ymin, y
      integer linespace, pg, flag, data_int, chr(8192), ios
      integer(1) data_byte
      integer, allocatable :: dat(:), tmp(:)
      character filein*200, fileout*200, case*1

      i = iargc()
      if (i.ne.3) then
        write (6,'(A)') '\nVICEtoPS - Paul David Buchan, 2004'
        write (6,'(A)') 'Usage: vicetops[exe] case_flag '//
     &  'VICE_output_filename PostScript_filename'
        write (6,'(A)') 'For upper case character set, case_flag = u'
        write (6,'(A)') 'For lower case character set, case_flag = l\n'
        write (6,'(A)') 'e.g., vicetops u viceprnt.out viceprnt.ps\n'
        stop
      end if

      i = 1
      call getarg (i, case)
      if ((case.eq.'u').or.(case.eq.'U')) then
        offset = 0
      else if ((case.eq.'l').or.(case.eq.'L')) then
        offset = 2048
      else
        write (6, '(A)') '\nInvalid case flag. '//
     &  'Type vicetops[exe] for usage.\n'
        stop
      end if
      i = 2
      call getarg (i, filein)
      i = 3
      call getarg (i, fileout)

C     Read in character set
      open (unit=1, file='characters.390059-01.bin', form='unformatted',
     & access='direct', status='old', iostat=ios, recl=1)
      if (ios.ne.0) then
        write (6, '(A)') 'Cannot open character set file.\n'
        stop
      end if
      do i = 1, 8192
        read (1, rec=i) data_byte
        if ((data_byte.lt.0).and.(ios.eq.0)) then
          data_int = 256 + data_byte
        elseif ((data_byte.ge.0).and.(ios.eq.0)) then
          data_int = data_byte
        endif
        chr(i) = data_int
      end do
      close (unit=1)

C     Open VICE output file and count bytes
      open (unit=1, file=trim(filein), form='unformatted', 
     & access='direct', status='old', iostat=ios, recl=1)
      if (ios.ne.0) then
        write (6,'(A)') 'Cannot open VICE output file.\n'
        stop
      end if
      i = 0
      ios = 0
      do while (ios.eq.0)
        i = i + 1
        read (1, rec=i, iostat=ios) data_byte
      end do
      close (unit=1)
      nchar = i - 1

C     Allocate memory for arrays dat and tmp for VICE output file data
      allocate (dat(nchar), tmp(nchar))

C     Read VICE output file into array dat
      open (unit=1, file=trim(filein), form='unformatted', 
     & access='direct', status='old', recl=1)
      do i = 1, nchar
        read (1, rec=i, iostat=ios) data_byte
        if ((data_byte.lt.0).and.(ios.eq.0)) then
          data_int = 256 + data_byte
        elseif ((data_byte.ge.0).and.(ios.eq.0)) then
          data_int = data_byte
        endif
        dat(i) = data_int
      end do
      close (unit=1)

C     Remove all line-feeds from file and store in tmp
      c = 0
      do i = 1, nchar
        if (dat(i).ne.10) then
          c = c + 1
          tmp(c) = dat(i)
        end if
      end do
      nchar = c

C     Re-map ASCII to CBM printout for each character in line
      do i = 1, nchar
        if ((tmp(i).ge.0).and.(tmp(i).le.31)) then
          dat(i) = tmp(i) + 128
        else if ((tmp(i).ge.32).and.(tmp(i).le.63)) then
          dat(i) = tmp(i)
        else if ((tmp(i).ge.64).and.(tmp(i).le.95)) then
          dat(i) = tmp(i) - 64
        else if ((tmp(i).ge.128).and.(tmp(i).le.159)) then
          dat(i) = tmp(i) + 64
        else if ((tmp(i).ge.160).and.(tmp(i).le.191)) then
          dat(i) = tmp(i) - 64
        else if ((tmp(i).ge.192).and.(tmp(i).le.223)) then
          dat(i) = tmp(i) - 128
        end if
      end do

C     Write header info for Postscript file
      open (unit=2, file=trim(fileout), status='new', iostat=ios)
      if (ios.ne.0) then
        write (6, '(A)') 'Cannot open new PostScript file.\n'
        stop
      end if

      write (2, '(A)') '%!PS-Adobe-3.0'
      write (2, '(A)') '%%Title: Commodore Printout'
      write (2, '(A)') '%%Creator: vicetops.f - Paul David Buchan, 2004'
      write (2, '(A)') '%%Pages: (atend)'
      write (2, '(A)') '%%Orientation: Portrait'
      write (2, '(A)') '0.000 0.000 0.000 setrgbcolor'
      write (2, '(A)') '8 dict begin'
      write (2, '(A)') '/FontType 3 def'
      write (2, '(A)') '/FontMatrix [.001 0 0 .001 0 0] def'
      write (2, '(A)') '/FontBBox [0 0 750 750] def'
      write (2, '(A)') 
      write (2, '(A)') '/Encoding 256 array def'
      write (2, '(A)') '0 1 255 {Encoding exch /.notdef put} for'
      do dec = 0, 255
        write (2, '(1A9,1I0,1A5,1I0,1A4)') 
     & 'Encoding ', dec, ' /cbm', dec, ' put'
      end do
      write (2, '(A)')
      write (2, '(A)') '/CharProcs 3 dict def'
      write (2, '(A)') 'CharProcs begin'
      write (2, '(A)') '/.notdef {} def'

C     Decode CBM character set and redefine default PostScript font set
      m = 1
      do dec = 0, 255
        write (2, '(1A4,1I0)') '/cbm', dec
        write (2, '(A)') '{ 40.0 setlinewidth'
        write (2, '(A)') '2 setlinecap'
        write (2, '(A)') '[] 0 setdash'
        do row = 0, 7
          do col = 0, 7
            p(col) = iand (ishft (chr(m+offset), col - 7), 1)
          end do
          m = m + 1
          do col = 0, 7
            if (p(col+1).eq.1) then
              write (2, '(1F6.2,1X,1F6.2,1X,1A6)') 
     &        real (col * 93.75), real (750.0 - (row * 93.75)), 'moveto'
              write (2, '(1F6.2,1X,1F6.2,1X,1A6)') 
     &        real ((col * 93.75) + 31.25),
     &        real (750.0 - (row * 93.75)), 'lineto'
            end if
          end do
        end do
        write (2, '(A)') 'stroke'
        write (2, '(A)') '} bind def'
        write (2, '(A)')
      end do
      write (2, '(A)') 'end'

C     Build new character set
      write (2, '(A)') '/BuildGlyph'
      write (2, '(A)') '{1000 0'
      write (2, '(A)') '0 0 750 750'
      write (2, '(A)') 'setcachedevice'
      write (2, '(A)') 'exch /CharProcs get exch'
      write (2, '(A)') '2 copy known not'
      write (2, '(A)') '{pop /.notdef}'
      write (2, '(A)') 'if'
      write (2, '(A)') 'get exec'
      write (2, '(A)') '} bind def'
      write (2, '(A)')
      write (2, '(A)') '/BuildChar'
      write (2, '(A)') '{ 1 index /Encoding get exch get'
      write (2, '(A)') '  1 index /BuildGlyph get exec'
      write (2, '(A)') '} bind def'
      write (2, '(A)') 'currentdict'
      write (2, '(A)') 'end'
      write (2, '(A)') '/ExampleFont exch definefont pop'
      write (2, '(A)') '/ExampleFont findfont 10 scalefont setfont'

C     Set left margin as one inch (72 dpi)
      xmin = 72

C     Set maximum number of characters per line
      maxchar = 70

C     Set top and bottom page margins as one inch
      ymax = 756
      ymin = 36

C     Set spacing between lines
      linespace = 12

C     Start printing at top of page
      y = ymax

C     Print out Commodore file
      pg = 1
      write (2, '(1A13,1I0)') '%%Page: Page ', pg
      c = 0
      flag = 0
      i = 1
      do while (i.le.nchar)

C       At beginning of a new line
        if (flag.eq.0) then
C         Found line-feed instead of text
          if (dat(i).eq.141) then
            y = y - linespace
            i = i + 1
C         Start new line of text
          else
            write (2, '(1I3,1X,1I3,1A7)') xmin,y,' moveto'
            write (2, '(1A6)', advance='no') '-3 0 <'
            c = 0
            flag = 1
          end if

C       Continuing a line of text already started
        else
C         Found line-feed which will terminate line of text
          if (dat(i).eq.141) then
            flag = 0
            c = 0
            write (2, '(A)') '> ashow'
            i = i + 1
            y = y - linespace
C         Length of line has reached maximum
          else if (c.eq.maxchar) then
            flag = 0
            c = 0
            write (2, '(A)') '> ashow'
            y = y - linespace
C         Print next character in file
          else
            write (2, '(1Z2.2)', advance='no') dat(i)
            i = i + 1
            c = c + 1
C           Last character in file?
            if (i.gt.nchar) then
              write (2, '(A)') '> ashow'
            end if
          end if
        end if
C       Reached bottom of page
        if (y.lt.ymin) then
          y = ymax
          write (2, '(A)') 'showpage'
          pg = pg + 1
          write (2, '(1A13,1I0)') '%%Page: Page ', pg
        end if
      end do

      write (2, '(A)') 'showpage'
      write (2, '(A)') '%%Trailer'
      write (2, '(1A9,1I0)') '%%Pages: ', pg
      write (2, '(A)') '%%EOF'
      close (unit=2)
      end