#!/usr/bin/perl
# This Perl script tries to decode data in Commodore tape format
# from corrupted pulse streams in the "TAP file" format.
# It tolerates large variations in the pulse widths.

# This script has been successfully used in decoding data from about
# 18 years old tapes that were unreadable by the Commodore ROM
# routines.

# Usage: ./decode.pl data.tap > data.bin 2> errors.txt
# You will need to edit "data.bin" - it contains two copies of each block.
# The first copy should start with the countdown sequence $89,$88,...,$81,
# and the second copy should start with 9,8,...,1.  You can extract and
# compare the two copies e.g. with GNU Emacs and diff.  Good luck!

# Improvements are welcomed at msmakela@nic.funet.fi.  On my tapes,
# the script seems to report bogus parity errors - the data bits are
# often correct.

{
    local $/, $cnt=0, $last="";
    $_=<>;
    for (split /([O-ÿ])/)
    {
	if ((length) > 19)
	{
	    warn "ignoring ", length ($last) + (length), " pulses at $cnt\n";
	    $last = "";
	}
	elsif ((length) < 19)
	{
	    # a medium pulse was misinterpreted as a long one
	    $last .= $_ if length ($last) || (length) > 1;
	    if (length ($last) == 19)
	    {
		$_ = $last; $last = "";
	    }
	}
	if (length == 19)
	{
	    warn "ignoring ", length ($last), " pulses at $cnt\n"
		if length ($last);
	    $last="";
	    $cnt++;
	    local @_ = split //;
	    local $bits = "", $parity = 0;
	    if ($_[1] gt $_[2]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[3] gt $_[4]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[5] gt $_[6]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[7] gt $_[8]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[9] gt $_[10]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[11] gt $_[12]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[13] gt $_[14]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[15] gt $_[16]) {$bits.="1";$parity=!$parity}else{$bits.="0"}
	    if ($_[17] gt $_[18]) {$parity=!$parity}
	    warn "parity error at $cnt\n" if ($parity);
	    print pack ("b*", $bits);
	}
    }
}