#! /usr/bin/perl

use utf8;        # This file in UTF-8

my $tsn = 0200000;
my $tapename = fixname ("NEWCOPYIN", "NEWCOPYIN");
my $date = 0;     # want days since 31/12/1899

my @label = (
	text ("HDDR"),
	$tsn,
	text ($tapename),
	0,			# Reel
	0,			# generation
	07777,			# retention period
	$date,
	(0) x 11 );


my %type = (
	amor => 0,
	grap => 012,
	norm => 002,
	allc => 022,
);
	
my $type = $type {norm};

for (my $a = 0; $a < @ARGV; ++$a) {

	$_ = $ARGV [$a];

	if (@label) {
		if ($_ eq '--tsn') {
			$label [1] = oct ($ARGV[++$a]);
			next;
		}

		if ($_ eq '--name') {
			my @name = text (fixname ($ARGV[++$a], "MAGTAPE"));
			for (my $n = 0; $n < 3; ++$n) {
				$label [2 + $n] = $name [$n];
			}
			next;
		}
	}

	if (/^--(\w+)/) {
		if (exists $type {$1}) {
			$type = $type {$1};
			next;
		}
	}

	unless (open FILE, $_) {
		print STDERR  "Can't open $_: $!\n";
		next;
	}

	if (@label) {
		write_block (@label);
		@label = ();
	}

	my $subfile = fixname ($_, "SUBFILE");

	# Write start of subfile sentinel

	my @start = (
		06,			# 0: Start of subfile
		0,			# 1: No checksumming
		text ($subfile),	# 2..4: name
		0,			# 5: no continuation
		0,			# 6: generation
		0,			# 7: undef
		0,			# 8: date written
		0,			# 9
		0,			# 10
		0,			# 11
		0,			# 12
		0,			# 13
		000004000,              # 14: what is this?
		(0) x 5
	);

	write_sentinel (@start);

	# write user sentinel with the file type

	my @user = (0) x 20;

	$user[0] = 040000004;	# user sentinel
	$user[5] = $type;

	write_sentinel (@user);

	my $blocks = 0;

	my @block;	# up to 2048 words

	while (<FILE>) {
		chomp;
		if ($type eq $type{grap}) {
			$_ =~ tr/`\\^a-z{|}~/'@↑_A-Z[!]-/;
			$_ = detab ($_);
			# delete non-icl
		}
		else {
			$_ = shifted ($_);
		}

		# Now calculate red tape

		my $end = length() & 3;

		if ($type != $type{amor}) {
			my $red;
			if ($type == $type{grap}) {
				$red = '000A';
			}
			else {
				# use MEND G501 hack
				$red = '00$A';
			}

			if ($end) {
				substr ($red, 0, 1) = substr ('0 @P', $end, 1);
			}

			$_ = "$red$_";
		}

		if ($end) {
			# add 1, 2, or 3 spaces to round EOL
			$_ .= " " x (4 - $end);
		}

		# length needed for the line, in words

		my $len = 1 + length () / 4;

		if ((@block + $len) > 2048) {
			++$blocks;
			write_block (@block);
			@block = ();
		}

		push @block, $len;
		push @block, text ($_);
	}

	if (@block) {
		++$blocks;
		write_block (@block);
	}

	# write the end of subfile sentinel

	my @end = (0) x 20;

	$end[0] = 040000000;	# end of subfke
	$end[1] = $blocks;

	write_sentinel (@end);
}

my @trailer = (0) x 20;
$trailer[0] = 000000007;

write_sentinel (@trailer);

write_mark ();
write_mark ();


# ICL 6 bit character set:

my @ICL;

BEGIN {
	@ICL  = (
		"0", "1", "2", "3", "4", "5", "6", "7",
		"8", "9", ":", ";", "<", "=", ">", "?",
		" ", "!", "\"", "#", "£", "%", "&", "'",
		"(", ")", "*", "+", ",", "-", ".", "/",
		"@", "A", "B", "C", "D", "E", "F", "G",
		"H", "I", "J", "K", "L", "M", "N", "O",
		"P", "Q", "R", "S", "T", "U", "V", "W",
		"X", "Y", "Z", "[", "\$", "]", "↑", "←",
	);
}

my %ICL;

BEGIN {
	for (my $i = 0; $i < @ICL; ++$i) {
		$ICL {$ICL [$i]} = $i;
	}

	$ICL {"^"} = $ICL {"↑"};
}

# Convert text string to words in ICL 6 bit char set

sub text {
	my $text = shift;
	my @ret;
	for (my $i = 0; $i < length $text; ++$i) {
		my $ch = substr ($text, $i, 1);
		$ch = exists $ICL {$ch} ? $ICL {$ch} : $ICL {" "};
		my $j = $i % 4;
		push @ret, 0 unless $j;
		$ret[-1] |= ($ch << (6 * (3 - $j)));
	}
	@ret
}


# Write a block to the tape

sub write_block {
	my $len = pack "N", @_ * 3;
	print $len;
	for (@_) {
		my $txt = pack "N", $_;
		print substr ($txt, 1, 3);
	}
}


# Write tape mark

sub write_mark {
	print pack "N!", -1;
}


# Write a sentinel

sub write_sentinel {
	write_mark ();
	write_block (@_);
}

# Remove tabs

sub detab {
	my $str = shift;
	my $ret = "";
	my $pos = 0;

	for (;;) {
		my $tab = index ($str, "\t", $pos);
		last if $tab == -1;
		$ret .= substr ($str, $pos, $tab - $pos);
		$ret .= " " x (8 - (length $ret) % 8);
		$pos = $tab + 1;
	}

	$ret .= substr ($str, $pos);
	
	return $ret;
}


# Convert to shift sequences

my %SHIFT;

my ($ALPHA, $BETA, $DELTA);

BEGIN {

	for (my $i = 0; $i < 32; ++$i) {
		$SHIFT {$ICL [$i]} = [ $ICL [$i], undef ];
	}

	$ALPHA = "\$";
	for (my $i = 32; $i < 64 - 4; ++$i) {
		$SHIFT {$ICL [$i]} = [ $ICL [$i], $ALPHA ];
	}

	$SHIFT{'\\'} = $SHIFT{'@'};	# Ugly

	my @beta = (
		"_", "a", "b", "c", "d", "e", "f", "g",
		"h", "i", "j", "k", "l", "m", "n", "o",
		"p", "q", "r", "s", "t", "u", "v", "w",
		"x", "y", "z", "{", 
		#                   "|", "}", "~", DEL,
	);

	$BETA = "]";
	for (my $i = 0; $i < @beta; ++$i) {
		$SHIFT {$beta [$i]} = [ $ICL [$i + 32], $BETA ];
	}

	$DELTA = "↑";
	for (0 .. 15) {	
		$SHIFT {chr $_} = [ $ICL [ $_ + 16 ], $DELTA ];
	}

	for (16 .. 31) {
		$SHIFT {chr $_} = [ $ICL [ $_ - 16 ], $DELTA ];
	}

	my %delta = (
		"\$" => "T", "]" => "U",
		"↑" => "V", "←" => "W",
		"|" => "X", "}" => "Y",
		"~" => "Z",
		"^" => "V",
	);

	while (my ($iso, $icl) = each %delta) {
		$SHIFT {$iso} = [ $icl, $DELTA ];
	}
}


sub shifted {
	my $str = $_[0];
	my $shift = $ALPHA;
	my $ret;

	for (my $i = 0; $i < length $str; ++$i) {
		my ($c, $s) = @ {$SHIFT {substr ($str, $i, 1)}};
		next unless defined $c;
		if ($s && $s ne $shift) {
			$ret .= $s;
			$shift = $s unless $s eq $DELTA;
		}
		$ret .= $c;
	}

	$ret;
}

sub fixname {
	my ($name, $default) = @_;

	$name =~ s/\.\w+$//;
	$name = uc $name;
	$name =~ tr/-A-Z 0-9//cd;
	$name =~ s/^[ -]+//;
	$name = substr ($name, 0, 12) if length $name > 12;
	$name = $default unless length $name;
	$name = sprintf "%-12s", $name;

	$name;
}

=head1 NAME

newcopyout.pl - make NEWCOPYOUT format virtual magtape

=head1 SYNOPSIS

perl newcopyout.pl  [--tsn serial ] [ --name tapename ] 
[ --amor | --grap | --norm | --allc ] 
file ... >magtape

=head1 DESCRIPTION

=cut
