#!/perl   # just to get emacs into perl mode when editing this

package numbers;

use strict;
use vars qw (%num @rand $valhead);  # must be global in package numbers
use English '-no_match_vars';

local $WARNING = 1;     # same as usual -w option


GAME::chdir "";

my $help = "Syntax:  gmX numbers <target>\n";
my $target = shift or die $help;
die $help if $target =~ /-h/i;
die "target name must be letters only.\n" if $target =~ /[^A-Za-z]/;
my $debug = (@ARGV and shift =~ /-v/);

my $spec = GAME::path "LaTeX/Numbers/$target-spec";
print "\tReading $spec\n";
my $memory = 0;
my $digits = 0;
my $fh = GAME::open $spec;
while (<$fh>) {
  s/\#.*//;
  $memory = $1 if /memory:\s*(\d+)/;
  last if ($digits) = /digits:\s*(\d+)/;
}
die "Must specify \#digits from 1 to 26\n" unless $digits > 0 and $digits < 27;
die "Because of the enormous time and filespace consumption, you may not\n".
  "use more than four digits unless you set a memory limit --- see docs.\n"
  if $digits > 4 and !$memory;
my @digits = ('a'..'z')[0..$digits-1];
safely_eval ("use vars qw (" . (join " ", (map { "\$$_" } @digits)) . ");");

my @prop = ();
my %type = ();  # override the one from parseconfigs.pl; don't care about that
my $keep = 0;
{
  local $INPUT_RECORD_SEPARATOR = "";
  while (<$fh>) {
    chomp;
    my ($def, $code) = split /\n/, $_, 2;
    $def =~ s/\#.*//;
    my ($type, $name) = split /\s+/, $def, 2;
    die "'$def' illegal --- must be 'flag' or 'value'\n"
	unless $type =~ /flag|value/i;
    $name =~ s/\s*$//;
    die "Name 'plain' illegal; it has special meaning.\n" if $name eq 'plain';
    safely_eval ("sub $name { $code\n}"); # newline so brace isn't commented
    die "bad spec for $name: $@\n" if $@;
    if ($name eq 'KEEP') {
      $keep = 1;
    }
    else {
      $type{$name} = lc $type;
      push @prop, $name;
    }
  }
}
close $fh;

my %idtonum;                     # $idtonum{id} = number
my %numtoid;                     # $numtoid{num} = id
my @desc = ("") x 10**$digits;   # $desc[num] = description
undef %num;                      # $num{flags}{vals} = list of numbers
$valhead = "values: ";
my $angstfile = GAME::open ">LaTeX/Numbers/$target-angst";
my $angst = 0;

my @numfile= sort grep /^\Q$target.\E.*[^~]$/o, GAME::contents "LaTeX/Numbers";
if (yesno("Generate new random $target\'s?", @numfile ? 'n' : 'y')) {
  @numfile and die 
    "Error: $numfile[0] etc exist and may contain manual allocation notes.\n",
    "Please save that information and remove these files.\n\n";
  srand;
  @rand = (0) x 10**$digits;
  my $eval = "";
  my $x = 'x' x ($digits - 2);
  for (@digits) {
    $eval .= "for \$$_ ('0'..'9') {\n";
    $eval .= "print \"\t\tGenerating \$a\${b}$x\\n\";\n" if /b/;
  }
  $eval .= "next unless &KEEP;\n" if $keep;
  $eval .= "\$_ = \"" . (join '', map { "\$$_" } @digits) . "\";\n";
  $eval .= "\$scrap::flags = '';\n";
  $eval .= "\$scrap::val = '$valhead';\n";
  for my $prop (@prop) {
    if ($type{$prop} eq 'flag') {
      $eval .= "\$scrap::flags .= '.$prop' if &$prop;\n";
    }
    else { # value
      $eval .= "\$scrap::val .= sprintf '$prop=%020d, ', &$prop;\n";
    }
  }
  $eval .= "\$numbers::rand[\$_] = rand;\n";
  $eval .= "\$scrap::flags = '.plain' if \$scrap::flags eq '';\n";
  $eval .= "push \@{\$numbers::num{\$scrap::flags}{\$scrap::val}}, \$_;\n";
  $eval .= '}' x @digits;
  
  safely_eval ($eval);
  
  my (%lines, $maxper);
  if ($memory) {
    my $nlines = 1000 * $memory / ($digits + 1);
    my @lines;
    for my $flags (keys %num) {
      for my $val (keys %{$num{$flags}}) {
	$lines{$flags}{$val} = @{$num{$flags}{$val}};
	push @lines, $lines{$flags}{$val};
      }
    }
    @lines = sort { $a <=> $b } @lines;
    my $tot = 0;
    $maxper = 0;
    while (@lines and $tot + ($lines[0] - $maxper) * @lines <= $nlines) {
      $tot += ($lines[0] - $maxper) * @lines;
      $maxper = $lines[0];
      shift @lines;
    }
    $maxper += int (($nlines - $tot) / @lines) if @lines;
  }
  
  for my $flags (keys %num) {
    print "\t\tSorting and saving $target$flags\n";
    my $fh = GAME::open ">LaTeX/Numbers/$target$flags";
    for my $val (sort keys %{$num{$flags}}) {
      my $v = $val;
      $v =~ s/(\D)0+(\d)/$1$2/g;
      $v =~ s/, *$//;
      print $fh "\n$v\n";
      my $desc = desc($flags, $v);
      my @list = sort { $rand[$a] <=> $rand[$b] } @{$num{$flags}{$val}};
      splice @list, $maxper if $memory and $lines{$flags}{$val} > $maxper;
      for (@list) {
	print $fh "$_\n";
	$desc[$_] = $desc;
      }
      delete $num{$flags}{$val};
      $num{$flags}{$v} = \@list;
    }
    close $fh;
  }  
  undef @rand;  # all done with this memory
  print "\tDone generating $target\'s.\n\n";
}
else {
  local $INPUT_RECORD_SEPARATOR = "";
  for my $numfile (@numfile) {
    print "\tReading $numfile\n";
    my ($flags) = $numfile =~ /(\..*)/;
   if ($flags ne '.plain') {
      my @tmp = split /\./, $flags;
      shift @tmp;  # first is blank
      for (@tmp) {
	angst("'$_' in file $numfile is not a known flag") 
	  unless exists $type{$_} and $type{$_} eq 'flag';
      }
    }
    my $fh = GAME::open "LaTeX/Numbers/$numfile";
    while (<$fh>) {
      my @lines = split /\n/;
      my $val = shift @lines;
      if ($val =~ /^$valhead\s*(.*)/o) {
	my %val = map { split /=/ } split /,\s*/, $1;
	for (keys %val) {
	  angst("'$_' in file $target$flags is not a known value")
	      unless exists $type{$_} and $type{$_} eq 'value';
	  angst("value '$_' given illegal value '$val{$_}' in $target$flags")
	      unless $val{$_} =~ /^\d+$/;
	}
      }
      else {
	angst("$target$flags has bad values header line:  $val");
	next;
      }
      my $desc = desc($flags, $val);
      for (@lines) {
	if (/^(\d{$digits})(?!\d)(.*)$/o) {
	  my ($n, $note) = ($1, $2);
	  push @{$num{$flags}{$val}}, $n;
	  $numtoid{$n} = $1 if $note =~ /^\s*( \S.*?)\s*$/;
	  $desc[$n] = $desc;
	  $idtonum{$1} = $n if $note =~ /^\s*AUTO for\s*(.*?)\s*$/;
	}
	else {
	  angst("$target$flags had bad line:  $_");
	}
      }
    }
    close $fh;
  }
}


my %find_tex_skip = map { (GAME::path $_, undef) }
  qw( Charsheets/Extracts LaTeX/Numbers );
sub find_tex {
  my ($dir, $list) = @_;
  my @contents = GM::contents $dir;
  my @do = ();
  print "\t\t$dir/\n" if length $dir;
  for (sort @contents) {
    /^(\.\.?|DVI|CVS|RCS)$/ and next;
    my $look = length $dir ? "$dir/$_" : $_;
    if (-d $look) {
      push @do, $look unless exists $find_tex_skip{$look};
      next;
    }
    if (/\.tex$/) {
      print "\t\t\t$_\n";
      push @$list, $look;
    }
  }
  for (@do) { find_tex($_, $list) }
}
    
if (yesno("Assign $target\'s?", 'y')) {
  # at this point we have the @{$num{$flag}{$val}}, %idtonum, %numtoid info
  my @files;
  print "\tSearching for .tex files\n";
  find_tex("", \@files);
  print "\tFinding properties of \\$target\'s in those .tex files\n";
  my $assign = GAME::open ">LaTeX/Numbers/$target-assigned.tex";
  print $assign "% This is an automatically generated file.\n" .
    "% Do not edit it by hand.\n\n";
  my (%prop, %source);
  for my $file (@files) {
    print "\t\t$file\n";
    local $INPUT_RECORD_SEPARATOR = undef;
    my $fh = GM::open $file;
    $_ = <$fh>;
    close $fh;
    next unless /\S/;
    s/(^|[^\\])((\\\\)*)%.*?(\n|\Z)/$1$2/mg;  # zot comments
    my @info = map { s/\s+/ /g; $_ } /\\\Q$target\E\s*{(.*?)}\s*{(.*?)}/gso;
    while (@info) {
      my ($id, $prop) = (shift @info, shift @info);
      angst ("illegal braces in id $id in $file") if $id =~ /{|}/;
      angst ("illegal braces in desc $prop in $file") if $prop =~ /{|}/;
      $prop =~ tr/ //d;
      $id =~ s/^\s+//;
      $id =~ s/\s+$//;
      if (exists $prop{$id} and $prop{$id} ne '') {
	if ($prop ne '' and
	    (join '%', sort grep !/=0$/, split /,/, $prop{$id}) ne
	    (join '%', sort grep !/=0$/, split /,/, $prop)) {
	  angst("$target \"$id\" redefined as {$prop} in $file",
		" after being defined as {$prop{$id}} in $source{$id}");
	}
      }
      else {
	$source{$id} = $file;
	$prop{$id} = $prop;
      }
    }
  }

  print "\tAssigning numbers\n";
  # if spec is trivial, all never-marked things are plain
  unless (@prop) { for my $id (keys %prop) { $prop{$id} ||= 'plain' } }
  my %assigned = ();
  for my $id (keys %prop) {
  if ($prop{$id} ne '') {
      my %have;
      for my $prop (split /,/, $prop{$id}) {
	if ($prop =~ /=/) {  # a 'value' property
	  my ($name, $val) = split /=/, $prop;
	  if (!exists $type{$name} or $type{$name} ne 'value') {
	    angst("$target \"$id\" defined with unknown value '$name'",
		  " in $source{$id}");
	  }
	  elsif ($val !~ /^\d+$/) {
	    angst("$target \"$id\" defined with non-numerical value \"$val\"",
		  " for $name in $source{$id}");
	  }
	  else {
	    $val =~ s/^0+//;
	    $have{$name} = $val;
	  }
	}
	else {  # a 'flag' property
	  if ($prop ne 'plain' and 
	      (!exists $type{$prop} or $type{$prop} ne 'flag')) {
	    angst("$target \"$id\" defined with unknown flag '$prop'",
		  " in $source{$id}");
	  }
	  else {
	    $have{$prop} = 1;
	  }
	}
      }
      my $flags = "";
      my $val = $valhead;
      for my $prop (@prop) {
	if ($type{$prop} eq 'flag') {
	  $flags .= ".$prop" if $have{$prop};
	}
	else {
	  $have{$prop} = 0 unless $have{$prop};
	  $val .= "$prop=$have{$prop}, ";
	}
      }
      $val =~ s/, $//;
      angst("$target \"$id\" defined as both plain and $flags in $source{$id}")
	  if $have{'plain'} and $flags ne "";
      $flags = ".plain" if $flags eq '';
      if (exists $idtonum{$id}) {
	my $desc = desc($flags, $val);
	if ($desc != $desc[$idtonum{$id}]) {
	  angst("$target \"$id\" was assigned as ${$desc[$idtonum{$id}]}\n",
		"  but is now $$desc ($source{$id}); re-assigning");
	  delete $numtoid{$idtonum{$id}};
	  delete $idtonum{$id};
	}
      }
      if (exists $num{$flags}{$val}) {
	my $n;
	if (exists $idtonum{$id}) {
	  $n = $idtonum{$id};
	}
	else {
	  ($n) = grep { not exists $numtoid{$_} } @{$num{$flags}{$val}};
	  $numtoid{$n} = " AUTO for $id" if defined $n;
	}
	if (defined $n) {
	  print $assign "\\assign\@number{$id}{$n}\n";
	  print "\t\t$n\t$id\n";
	  $assigned{$id} = 1;
	}
	else {
	  angst("Ran out of numbers fitting $prop{$id}; unable to satisfy ",
		"\"$id\" for $source{$id}");
	}
      }
      else {
	angst("No numbers fit $prop{$id} ($source{$id} for $target \"$id\")");
      }
    }
    else {
      angst("$target \"$id\" used in $source{$id} (and possibly others)",
	    " never has properties defined");
    }
  }
  close $assign;
  print "\tChecking for obsolete auto-assignments\n";
  if (my @obsolete = grep { not exists $assigned{$_} } keys %idtonum) {
    print map { "\t\tobsolete: $_\n" } @obsolete;
    yesno("Purge obsolete auto-assigns?", 'y')
      and delete @numtoid{ @idtonum{ @obsolete } } 
  }
  print "\tSaving $target sets\n";
  for my $flags (keys %num) {
    print "\t\t$target$flags\n";
    my $fh = GAME::open ">LaTeX/Numbers/$target$flags";
    for my $val (sort keys %{$num{$flags}}) {
      print $fh "\n$val\n";
      for my $num (@{$num{$flags}{$val}}) {
	print $fh $num;
	print $fh $numtoid{$num} if exists $numtoid{$num};
	print $fh "\n";
      }
    }
    close $fh;
  }
}

print "\tWriting $target-allocations\n";
my $alloc = GAME::open ">LaTeX/Numbers/$target-allocations";
for my $n (sort { $a <=> $b } keys %numtoid) {
  print $alloc "$n$numtoid{$n} (${$desc[$n]})\n";
}
close $alloc;

close $angstfile;
$angst 
  ? print "That caused some angst; please soothe my woes (in $target-angst).\n"
  : print "No angst; all is well.\n";
print "Done with $target\'s.\n";
return;


my %desc;  # store references to repeated strings to save space
sub desc {
  my $flags = shift;
  my $val = shift;

  return $desc{$flags}{$val} if exists $desc{$flags}{$val};

  my $desc = "$flags, $val";

  $desc =~ s/$valhead//o;
  $desc =~ s/^\.//;
  $desc =~ s/\./, /g;
  $desc =~ s/=/ /g;

  return $desc{$flags}{$val} = \$desc;
}  


sub safely_eval {
  print "\n@_\n" if $debug;
  eval "package numbers_eval; @_";
  die $@ if $@;
}


sub yesno {
  my $prompt = shift;
  my $default = lc shift;

  $prompt = "$prompt [$default]" if $default;
  while (1) {
    print "$prompt ";
    chomp (local $_ = lc <STDIN>);
    $_ ||= $default;
    return 1 if /^\s*y\s*$/ or /^\s*yes\s*$/;
    return 0 if /^\s*n\s*$/ or /^\s*no\s*$/;
  }
}


sub angst {
  print STDOUT "WOE: @_\n";
  print $angstfile  "WOE: @_\n";
  $angst = 1;
}