#!/usr/bin/perl
# 
# Copyright © 2015-2020 by Vincent Slyngstad
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS LISTED ABOVE BE LIABLE
# FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# 
# Except as contained in this notice, the names of the authors above
# shall not be used in advertising or otherwise to promote the sale, use
# or other dealings in this Software without prior written authorization
# from those authors.

@rem = '
@echo off
c:\perl5\bin\perl %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
@rem ' if @rem;

#
# Check tapes created by EPIC.SV.
#
# Each tape block may have arbitraty leader (0000 or 0200),
# followed by a 0201 byte, which marks the start of
# a block.
#
# A block is broken into 8 word segments.  Each pair of words
# in the 8 word segment is represented by 3 bytes, concatenated
# from left to right.  (If the bits of the bytes were;
# abcdefgh ijklmnop qrstuvwx, the resulting words will be 
# abcdefghijkl mnopqrstuvwx.)  Parity is computed for each word,
# with a 1 indicating even parity.  A 13th byte is constructed
# from the parity values, and checked against a parity byte in
# the tape.
#
# There is a special initial segment of 8 words, which contains
# the file name, block number, and some unknown other stuff.
#
# After 041 such segments, a block of 0400 words has been read.
# Two bytes of CRC follow.
#

#
# Update the parity byte with the parity of a 
# new word (even == 1).
sub dopar {
  local($word) = @_;
  local($even);
  $even = 1;
  while ($word) {
    $word &= $word - 1;
    $even = !$even;
  }
  $parity = $parity + $parity + $even;
}

# Update the CRC values.
# I'm sure this could be cleaned up quite a bit.
sub docrc {
  local($tmp0) = @_;

  $ac = $tmp0 ^ $crc2;
  $ac = int($ac/2) + (($ac&1)<<12); # cll rar
  $ac = int($ac/2) + (($ac&1)<<12); # rar
  for ($tmp1 = -7; $tmp1; $tmp1++) {
    $ac ^= 010000 if $ac & 04000; # spa; cml
    $ac = int($ac/2) + (($ac&1)<<12); # rar
  }
  $tmp1 = $ac & 07777;
  if ($ac & 04000) {
    $ac = int((($ac&010000)+$crc1)/2) + (($crc1&1)<<12); # tad crc1; rar
    $ac = 2*($ac & 07777) + !($ac & 010000); # cml ral
  } else {
    $ac = $crc1;
  }
  $crc2 = $ac & 07777;
  $crc1 = 4*($tmp1 & 060);
  $crc2 ^= $crc1;
  $crc1 = $tmp1;
  $crc1 = int($crc1/2); # cll rar
  $crc1 = int($crc1/2) + (($crc1&1)<<12); # rar
  $crc1 = int($crc1/2) + (($crc1&1)<<12); # rar
  $crc1 = int($crc1/2) + (($crc1&1)<<12); # rar
  $tmp1 = int($crc1 / 4); # tad crc1; cll rar; cll rar; dca tmp1
  $crc1 ^= $tmp1;
}

sub sixbit {
  local($c1c2) = @_;
  # Both null?
  return unless $c1c2;
  #printf "0%04o ", $c1c2;
  local($c1, $c2) = ( ($c1c2>>6), ($c1c2 & 077) );
  #printf "0%03o 0%03o\n", $c1, $c2;
  # No, print the first.
  print pack("C", ($c1^040) + 040);
  return unless $c2;
  print pack("C", ($c2^040) + 040);
}

#
# Read a file in EPIC loader format.
sub readEPIC {
  local($file, *core) = @_;
  #
  # Open the input file in binary mode and read it in.
  open(INPUT, $file) || die "$file: $!";
  binmode(INPUT);
  for (;;) {
    # First, ignore leader.
    while (read(INPUT, $top, 1)) {
      $top = unpack("C", $top);
      next if $top == 0000;
      next if $top == 0200;
      last if $top == 0201;
      die "$file: no 'start of block' punch";
    }
    # Init for block
    $crc1 = $crc2 = 0;
    # Parse a block, which is a header chunk and 32 data chunks.
    # NB: We don't check the header for valid content, just for 
    # parity and CRC.
    @hdr = ();
    for ($c = 0; $c < 33; $c++) {
      # Check a chunk.  Each chunk is 12 bytes followed by parity.
      $parity = 0;
      for ($i = 0; $i < 4; $i++) {
        if (read(INPUT, $top, 3) == 3) {
          ($c1, $c2, $c3) = unpack("CCC", $top);
          &docrc($c1);
          &docrc($c2);
          &docrc($c3);
          $c1 = ($c1<<16) | ($c2<<8) | $c3;
          $c2 = $c1 & 07777;
          $c1 = $c1 >> 12;
          #printf("0%04o, 0%04o\n", $c1, $c2);
          &dopar($c1);
          &dopar($c2);
          push(@hdr, $c1, $c2) if $c == 0;
        } else {
          die "$file: EOF in block";
        }
      }
      if (read(INPUT, $top, 1)) {
        $top = unpack("C", $top);
        $str = sprintf("0%03o vs 0%03o\n", $parity, $top);
        die "$file: bad parity $str" unless $parity == $top;
        #warn "$file: OK  parity $str" if $parity == $top;
        &docrc($top);
        if ($c == 0) {
          ($_, $c1c2, $c3c4, $c5c6, $e1e2, $blk, $size, $_) = @hdr;
          &sixbit($c1c2);
          &sixbit($c3c4);
          &sixbit($c5c6);
          printf(".");
          &sixbit($e1e2);
          printf(", block %d\n", $blk);
        }
      }
    }

    # Check block CRC
    if (read(INPUT, $top, 1)) {
      $top = unpack("C", $top);
      $str = sprintf("0%03o vs 0%03o\n", $crc1, $top);
      warn "$file: crc1: $str" unless $crc1 == $top;
    }
    if (read(INPUT, $top, 1)) {
      $top = unpack("C", $top);
      $str = sprintf("0%03o vs 0%03o\n", $crc2, $top);
      die "$file: crc2: $str" unless $crc2 == $top;
    }
    
    # Check if last block
    if (read(INPUT, $top, 1)) {
      $top = unpack("C", $top);
      # NB: We require a frame of L/T between each block.
      next if $top == 0000;
      next if $top == 0200;
      last if $top == 0377;
      die "$file: junk at 'end of block'";
    }
  }
  close(INPUT);
}

&readEPIC($ARGV[0]);

__END__
:endofperl