#!/usr/bin/perl

###	sylver - compute winning moves in Sylver Coinage.
#
#	If g.c.d. > 1, you can get erroneous results
#	from setting the precision too low.

sub usage {
	die "usage: $prog [option] ... number ...\n"
	. "-a\tshow all winning moves\n"
	. "-mN\tset precision to N longwords\n"
	. "-s\tread positions from standard input\n"
	. "-uFILE\twrite P-positions to FILE\n"
	. "-v\tshow losing moves and replies\n"
}

use integer;

$0 =~ m![^/]+$! and $prog = $&;
while (@ARGV and $ARGV[0] =~ /^-/) {
	$flag = shift;
	$flag eq "-a" and $allflag = 1 and next;
	if ($flag eq "-m") {
		&usage unless @ARGV;
		$mflag = shift;
		&usage unless $mflag !~ /\D/ && $mflag;
		next;
	}
	elsif ($flag =~ /^-m/) {
		$mflag = $';
		&usage unless $mflag !~ /\D/ && $mflag;
		next;
	}
	elsif ($flag eq "-s") {
		$streammode = 1;
		next;
	}
	elsif ($flag eq "-u") {
		&usage unless @ARGV;
		$ufile = shift;
		next;
	}
	elsif  ($flag =~ /^-u/) {
		$ufile = $';
		next;
	}
	$flag eq "-v" and $vflag = 1 and next;
	&usage;
}
if ($ufile) {
	$streammode and die "sylver: -u not allowed with -s\n";
	open UFILE, ">$ufile" or die "sylver: cannot write to $ufile\n";
}
if ($streammode) {
	@ARGV
	and die "$prog: command-line argument position not allowed with -s\n";
	while ($_ = <STDIN>) {
		chomp;
		@_ = split " ", $_;
		$_[-1] or pop @_;	# Drop final zero.
		&mainsolve(@_);
	}
}
else {
	@ARGV or &usage;
	&mainsolve(@ARGV);
}
exit 0;

sub mainsolve {
	grep /\D/, @_ and &usage;
	grep {$_<2} @_ and die "$prog: numbers must be greater than 1\n";
	foreach (sort {$a<=>$b} @_) {		# Eliminate duplicates.
		$_ == $prev or $prev = $_ and push @arg, $_;
	}
	$g = &gcd(@arg);
	die "$prog: you must specify -m if g > 1\n"
		if $g > 1 && !$mflag;
	warn "$prog: g = 1, ignoring -m$mflag\n"
		if $g == 1 && $mflag;
	print join " ", "#", @arg, "\n";
	if ($g==1) {
		$t = syltop(@arg);
		if ($t==1) {
			print "P\n";
			exit 0;
		}
		$precision = 1 + $t / 32;
	}
	else {
		$precision = $mflag;
		$t = $precision * 32 - 1;
	}
	$string = $empty;
	for (@arg) { $string = &make($_, $string) }
	&init;

	$tag = "# g=$g";
	if ($g == 1) {
		$tag .= ", t=$t";
		if (&quiet($string)) { $tag .= " quiet ender" }
	}
	print "$tag\n";

# If it's a known long P-position, and -v isn't specified,
# just print "P" and exit.

	if (!$vflag && $safe{$string} && $arg[0] != 12) {
		print "P\n";
		exit;
	}

	&solve(1, $allflag, $string) || print "P\n";
}

sub init {
	$empty = chr(0) x (4 * $precision);
	%safe = ();
	%canned1 = (2 => [3], 3 => [2], 4 => [6], 6 => [4,9],
		8 => [12], 10 => [5,14,26]);
	unless ($g % 2) {
		&addsafe([4, 6], [8, 10, 22], [8, 10, 12, 14],
			[8,12,18,22], [8,12,26,30], [8,12,34,38],
			[8,12,42,46], [8,12,50,54]);
	}
	unless ($g % 3) {
		&addsafe([6, 9], [12, 15, 18], [12, 18, 21]);
	}
	unless ($g % 4) {
		&addsafe([8, 12]);
	}
}

sub addsafe {
	for (@_) {
		my $spos = $empty;
		for my $m (@$_) { $spos = &make($m, $spos) }
		$safe{$spos} = 1
			unless (~"$spos" & "$string") =~ /[^\0]/o;
	}
}

sub solve {
	(my $printflag, my $allflag, my $pos) = @_;
	my $retval = 0;
	my $count=0;
	my $pair = $empty;
	my $b; my $x; my $response; my $bomb;

# Is this position a single value?

	for ($b=1; $b<=$t; $b++) { last if vec($pos, $b, 1) }
	$pos eq &make($b, $empty)
		and return solve1($printflag, $allflag, $b);

# Is it {2, 3}?

	ord(substr $pos, 0, 1) == 0xfc and return 0;

# To save time, check for an instant winner:

	for ($x=2; $x<=$t; $x++) {
		next if vec($pos, $x, 1);	# illegal
		return $x if $safe{&make($x, $pos)};
	}

	my $fuse = 0;
	for ($x=2; $x <= $t; $x++) {
		if (vec($pos, $x, 1)) {		# Not a legal move.
			$fuse ||= $x;		# Measure the fuse.
			last if --$bomb == 0;
			next;
		}
		$bomb = $fuse;		# Light the fuse.
		next if vec($pair, $x, 1);	# Eliminated by pairing.
		my $newpos = &make($x, $pos);
		my $safe = $safe{$newpos};
		if (!$safe and $response = &solve(0, 0, $newpos)) {
			vec($pair, $response, 1) = 1 if $response > $x;
			if ($printflag && $vflag) {

		# Print it as a clique if appropriate.

				if ($response > $x) { $clique = 1 }
				else {
					my $rpos = &make($response, $pos);
					$clique = !vec($rpos, $x, 1);
				}
				print $clique? "($x,$response)\n"
					:"$x? $response!\n";
			}
		}
		else {
			unless ($safe) {
				$safe{$newpos} = 1;
				print UFILE &zdisp($newpos);
			}
			$printflag and print "$x!\n";
			$allflag or return $x;
			$retval ||= $x;
		}
	}
	return $retval;
}

# syltop
#
#	ARGUMENTS: position as a sorted set of numbers.

sub syltop {
	my $top = ($_[-1] - 1) * ($_[-2] - 1) - 1;
	my $tprecision = 1 + $top / 32;
	my $vec = chr(0) x $tprecision;
	$t = $top;	# temporarily
	for (@_) { $vec = &make($_, $vec) }
	while ($top > 1 && vec($vec, $top, 1)) { $top-- }
	return $top;
}

sub solve1 {
	(my $printflag, my $allflag, my $pos) = @_;
	my $sols = $canned1{$pos};
	if ($sols) {
		if ($printflag) {
			foreach (@$sols) {
				print "$_!\n";
				$allflag or last;
			}
		}
		return ${$sols}[0];
	}
	&isprime($pos) and return 0;
	die "$prog: cannot solve {$pos}\n";
}

# make - make a move in a position.
#
#	ARGUMENTS:	0. move
#			1. position as string

sub make {
	my $i;
	my $j;
	(my $move, my $pos) = @_;
	vec($pos, $move, 1) = 1;
	for ($i=2; $i<=$t-$move; $i++) {
		next unless vec($pos, $i, 1);
		vec($pos, $move+$i, 1) = 1;
	}
	return $pos;
}

# quiet - is a position a quiet ender?
#
#	ARGUMENT:	0. position as string
#
# This algorithm uses the characterization that no two legal moves
# sum to t.

sub quiet {

# Find highest legal move.

	my ($post, $i, $t2);
	for ($post=$t; $post>0; $post--) {
		vec($_[0], $post, 1) or last;
	}
	$t2 = $t / 2;
	for ($i=1; $i<=$t2; $i++) {
		return 0 if !vec($_[0], $i, 1) && !vec($_[0], $post-$i, 1);
	} 
	return 1;
}

# Mathematical functions:

sub isprime {
	my $x = $_[0];
	my $i;
	$x % 2 or return 0;
	my $lim = int(sqrt($x));
	for ($i=3; $i<=$lim; $i+=2) { $x % $i or return 0; }
	return 1;
}

sub gcd {
	@_ == 1 and return $_[0];
	my @list = sort {$a<=>$b} @_;
	my $a = shift @list;
	my $b = shift @list;
	my $g = gcd2($a,$b);
	@list or return $g;
	return &gcd2($g, &gcd(@list));
}

sub gcd2 {
	(my $a, my $b) = @_;
	while ($a) { ($b, $a) = ($a, $b % $a) }
	return $b;
}

#	Display functions:

sub bits {
	my $r = "";
	for ($b=0; $b<=$t; $b++) { $r .= vec($_[0], $b, 1) }
	return $r;
}

sub zdisp {
	my $r = "";
	my $goal = $empty;
	for ($b=0; $b<=$t; $b++) {
		next unless vec($_[0], $b, 1) && !vec($goal, $b, 1);
		$r .= "$b ";
		$goal = &make($b, $goal);
	}
	return $r . "0\n";
}

#	Convert a bitmap to a canonical array.

sub makearray {
	my $pos = shift;
	my $got = $empty;
	my @ret = ();
	for ($b=2; $b<=$t; $b++) {
		last if $pos eq $got;
		next unless vec($pos, $b, 1) && !vec($got, $b, 1);
		push @ret, $b;
		$got = &make($b, $got);
	}
	return @ret;
}