簡単な、圧縮、復元ツール、compress, expandです。

compressは、読み込んだ文字が繰り返されていたら、反復符号、繰り返し回数、文字に置き換え出力します。

compressは、下記の通り。

# compress.r4 -- compress standard input
      character getc
      character buf(MAXCHUNK),c,lastc
      integer nrep,nsave
      # must have RCODE > MAXCHUNK or RCODE = 0

      nsave = 0
      for (lastc = getc(lastc); lastc != EOF; lastc = c) {
          for (nrep = 1; getc(c) == lastc; nrep = nrep + 1)
              if (nrep >= MAXCHUNK)     # xount repetitions
                  break
              if (nrep < THRESH)        # apppend short string
                  for ( ; nrep >0; nrep = nrep - 1) {
                      nsave = nsave + 1
                      buf(nsave) = lastc
                      if (nsave >= MAXCHANK)
                          call putbuf(buf,nsave)
                  }
               else {
                   call putbuf(buf,nsave)
                   call putc(RCODE)
                   call putc(lastc)
                   call putc(nrep)
                   }
          }
      call putbuf(buf,nsave) # put last chunk
      stop
      end

putbufはbufにたまったnsave個の文字を書き出します。

# putbuf.r4 -- output buf(1)...buf(nsave), clear nsave
      subroutine putbuf(buf,nsave)
      character buf(MAXCHUNK)
      integer nsave
      integer i

      if (nsave > 0) {
          call putc(nsave)
          for (i = 1; i <= nsave; i = i + 1)
              call putc(buf(i)
          }
      nsave = 0
      return
      end

expandは、下記の通り。

# expand.r4 -- uncompress standard input
      character getc
      character c,code
      
      while (getc(code) != EOF)
          if (code == RCODE) { # expand repetition
              if (getc(c) == EOF)
                  exit
              if (getc(code) == EOF)
                  exit
              while (code > 0)
                  call putc(c)
                  code = code - 1
              }
          else {
              for ( ; code > 0; code = code - 1) {
                  if (getc(c) == EOF)
                      break
                  call putc(c)
                  }
              if (c == EOF)
                  break
              ]
      stop
      end

compress,putbuf(),expandのWatcom Fortran77版は、下記の通り。

c compress -- compress standard input
      program compress
      integer*1 getc
      integer*1 buf(10),c,lastc         ! MAXCHANK(10)
      integer nrep,nsave
      ! must have RCODE > MAXCHUNK or RCODE = 0

      nsave = 0
      lastc = getc(lastc)
      while (lastc .ne. -1) do          ! EOF(-1)
          nrep = 1
          while (getc(c) .eq. lastc) do
              if (nrep .ge. 10) then    ! MAXCHUNK(10)
                  exit
              end if
              nrep = nrep + 1
          end while
          if (nrep .lt. 5) then         ! THRESH(5)
              while (nrep .gt. 0) do
                  nsave = nsave + 1
                  buf(nsave) = lastc
                  if (nsave .ge. 10) then ! MAXCHUNK(10)
                      call putbuf(buf,nsave)
                  endif
                  nrep = nrep - 1
              end while
          else
              call putbuf(buf,nsave)
              call putc(35)             ! #(35)
              call putc(lastc)
              call putc(nrep)
          endif
          lastc = c
      end while
      call putbuf(buf,nsave)            ! put last chunk
      stop
      end

c putbuf.for -- output buf(1)...buf(nsave), clear nsave
      subroutine putbuf(buf,nsave)
      integer*1 buf(10)                 ! MAXCHUNK(10)
      integer nsave
      integer i

      if (nsave .gt. 0) then
          call putc(nsave)
          i = 1
          while (i .le. nsave) do
              call putc(buf(i))
              i = i + 1
          end while
      end if
      nsave = 0
      return
      end

c expand.for -- uncompress standard input
      program expand
      integer*1 getc
      integer*1 c,code
      
      while (getc(code) .ne. -1) do     ! EOF(-1)
          if (code .eq. 35) then ! expand repetition RCODE(#(35))  
              if (getc(c) .eq. -1) then ! EOF(-1)
                  exit
              end if
              if (getc(code) .eq. -1) then ! EOF(-1)
                  exit
              end if
              while (code .gt. 0) do
                  call putc(c)
                  code = code - 1
              end while
          else
              while (code .gt. 0) do ! expand chunk
                  if (getc(c) .eq. -1) then ! EOF(-1)
                     exit
                  end if
                  call putc(c)
                  code = code - 1
              end while
              if (c .eq. -1) then       ! EOF(-1)
                  exit
              end if
          end if
      end while
      stop
      end