#! /usr/bin/perl

# Copyright (C) 2007-2018 Arne Wichmann

# GURPS is a trademark of Steve Jackson Games, and its rules and art
# are copyrighted by Steve Jackson Games. All rights for GURPS are reserved
# by Steve Jackson Games. This game aid is the original creation of Arne
# Wichmann and is released for free distribution, and not for resale, under
# the permissions granted in the <a
# href="http://www.sjgames.com/general/online_policy.html">Steve Jackson
# Games Online Policy</a>.

# If you have questions about these terms, or if you want to distribute
# modified versions, please ask me. I will usually try to grant permissions
# if they do not conflict with the above (or if they port this to another
# game) and if they agree in spirit with the GPL version 2. I have to use
# this license as this program might interfere with GURPS rights. -- aw@linux.de

# There may be instances of german in the code, if you have problems
# understanding ask me (possibly after trying babelfish) -- aw@linux.de

# oh yes, documentation is minimal, this is subject to change. If you ask
# me about that, you might speed me up quite a bit.

# -p : point value (without skills), default 25
# -r : point range (actual value is random between -p and -r), default as -p
# -d : max disadvantages, default 40
# -a : age; half this value is put into skills, default 20
# -j : job, default random
# -o : old configuration file syntax

# todo: social disads, skills
#   attrs <9 have wrong point val printed (1 bug for val==8, one for val<8)
#   attrs <8 have wrong disad val (-10 instead -20)
#   attr values of 8 are not printed

use strict;

use Getopt::Std;

sub readadv(\%);
sub skilltable($);

# $ok is global eof.
our $ok;

# to calculate attributes
our(@vallist)=(5,10,10,10,10,15,15,20,20);
our(%attrib)=('st',0,'dx',0,'iq',0,'ht',0);

my(%opts);
getopts('op:d:r:j:a:',\%opts);
$opts{'a'}=20 unless $opts{'a'}; # HACK
$opts{'p'}=25 unless $opts{'p'};
$opts{'d'}=40 unless $opts{'d'};
if (defined($opts{'r'})) {
  my($min,$max)=sort {$a<=>$b} ($opts{'p'},$opts{'r'});
  $opts{'p'}=$min+int(rand($max-$min+1));
}

# Initialisation. First the old variant which is not used anymore, then the
# new one, which uses Data::Dumper
my(%adweights,%disadweights,%values,%actions,%result,%resvalue,%jobskills,
  %skillbase,%jobs);
my($line);
# srand(time*$$);
if ($opts{'o'}) {
  $|=1;
  $line=rnl();
  while (!$ok) {
    $_=$line;
    if (/^Nachteile/) {
      $line=&readadv(\%disadweights);
      next;				# the new line is already read
    } elsif (/^Vorteile/) {
      $line=&readadv(\%adweights);
      next;				# the new line is already read
    } elsif (/^\S/) {
      warn "Unknown keyword: $_";
    } else {
      warn "Line begins with space: $_";
    }
    $line=rnl();
  }
} else {
  our($VAR1);
  for (@ARGV) { 
    /^\// or s/^/.\//;
    do "$_"; 
  }
  %adweights=%{$VAR1->[0]};
  %disadweights=%{$VAR1->[1]};
  %values=%{$VAR1->[2]};
  %actions=%{$VAR1->[3]};
  %jobskills=%{$VAR1->[4]};
  %skillbase=%{$VAR1->[5]};
  %jobs=%{$VAR1->[6]};
}

# my(@outdata)=(\%adweights,\%disadweights,\%values,\%actions);
# use Data::Dumper;
# $Data::Dumper::Indent=1;
# print Dumper \@outdata;
# exit 0;

# print (sum(values(%disadweights)));
# exit 0;

# now roll the dice
# weights are in disadweights / adweights

my($sum,$done);

# roll disadvantages
while ($sum>-$opts{'d'} && $done<1) {
  my($rand)=int(rand(sum(values(%disadweights))));
  for (keys(%disadweights)) {
    $rand-=$disadweights{$_};
    next if $rand>=0;
    # print "$_\n";
    if ($sum+$values{$_}<-$opts{'d'}) {
      $done=1;
      last;
    }
    $sum+=$values{$_};
    $result{$_}++;
    $resvalue{$_}+=$values{$_};
    delete($disadweights{$_});
    doactions($actions{$_}) if $actions{$_};
    # $wsum-=$disadweights{$_};
    last;
  }
}

# roll advantages
while ($sum<$opts{'p'}+60 && $done<2) { # attributes start at 8, not 10
  my($rand)=int(rand(sum(values(%adweights))));
  for (keys(%adweights)) {
    $rand-=$adweights{$_};
    next if $rand>=0;
    # print "$_\n";
    if ($sum>=$opts{'p'}+60) {
      $done=2;
      last;
    }
    $sum+=$values{$_};
    $result{$_}++;
    $resvalue{$_}+=$values{$_};
    delete($adweights{$_});
    doactions($actions{$_}) if $actions{$_};
    # $wsum-=$adweights{$_};
    last;
  }
}

# Beruf auswuerfeln
unless ($opts{'j'}) {
  $opts{'j'}=rolltable(%jobs);
}


# now roll skills for the job
my(%skillist); # also needed while printing
for my $job (split('/',$opts{'j'})) {
  my($age)=$opts{'j'};
  $age=~s+[^/]++g;
  $age=$opts{'a'}/(length($age)+1);
  if (my $table=$jobskills{$job}) {
    # %actions=%{$jobactions{$opts{'j'}}};
    while ($age-->0) {
      $_=rolltable(%$table);
      # this can not change weights after a prerequisite comes available.
      # furthermore it is tied to my house rule which converts prerequisites
      # into additional skill bases -- TODO
      my($ok);
      for my $i (split(/,/,$skillbase{$_})) {
	($i eq "DX" || $i eq "HT" || $i eq "ST" || $i eq "IQ") and next;
	next if grep { $i eq $_ } keys(%skillist);
	$ok=1;
	last;
      }
      redo if $ok;
      $skillist{$_}++;
      # doactions($actions{$_}) if $actions{$_};
    }
    for (keys(%skillist)) {
      $result{$_}=1;
      $resvalue{$_}=$skillist{$_}/2;
    }
  } elsif ($opts{'j'} ne 'none') { 
    print STDERR "Invalid job given: ".$opts{'j'}."\n";
  }
}

# TODO: werte fuer die Skills richtig ausrechnen

print $opts{'j'}." (sum = ".($sum-60)."):\n\n";

# for (keys(%result)) {
#   print "$_ (".$resvalue{$_}.")\n" if $result{$_}<=1;
#   print "$_ ".$result{$_}." (".$resvalue{$_}.")\n" if $result{$_}>1;
# }

my(%printres)=%result;
for ("ht","st","dx","iq") { # Attributes
  if ($printres{$_}) {printresult($_);} else {print "$_ 8 (-15)\n";}
  delete($printres{$_});
}

for (keys(%printres)) { # Advantages
  next if $resvalue{$_}<0;
  next if $skillist{$_};
  printresult($_);
  delete($printres{$_});
}

for (keys(%printres)) { # Disads
  next if $resvalue{$_}>0;
  printresult($_);
  delete($printres{$_});
}

for (keys(%printres)) { printresult($_); } # Skills

# end of main

# given a hash of keys and weights gives back one weightedly random key
sub printresult($) {
  $_=$_[0];
  print "$_ (".$resvalue{$_}.")\n" if $result{$_}<=1;
  print "$_ ".$result{$_}." (".$resvalue{$_}.")\n" if $result{$_}>1;
}

sub rolltable(%) {
  my(%t)=@_;
  my($rand)=int(rand(sum(values(%t))));
  for (keys(%t)) {
    $rand-=$t{$_};
    next if $rand>=0;
    # print "$_\n";
    return $_;
  }
}

sub readadv(\%) {
  # This line begins with \s+. The amount of space (indent level) for this
  # line will be the same for all following disadvantages. A line which is
  # not indented marks the end of the section. Lines which are more
  # indented are commands for this disadvantage.
  my($weights)=$_[0];
  my($line)=rnl();

  my $i=indentlevel($line);
  return if $i==0; # empty section
  my $name=''; # name of this disad

  while (!$ok) {
    my $il=indentlevel($line);

    if ($il==$i) {
      # doline; # sets $name
      # print $vorz>0?"adv":"dis",$line,"\n";

      # a line looks like: nachteil:weight:value
      # wir brauchen: weightsum, nachteil->weight, nachteil->value
      my($weight,$val);
      ($name,$weight,$val)=split(/:/,$line);
      $name=~s/^\s+//;
      $values{$name} and warn "Name $name multiple in $line";
      $$weights{$name}=$weight;
      my($levelad)=($val=~s+/lev$++);
      $values{$name}=$val;
      levelaction($name,$weight,$val) if $levelad;
      
    } elsif ($il>$i) {
      $line=sublines($line,$name);
      next;				# the new line is already read
    } else {
      return $line if $il==0;
      warn "Illegal indent decrease: $line";
    }
    $line=rnl();
  }

  return $line;
}

sub sublines($$) {
  my($line,$name)=@_;

  my($i)=indentlevel($line);
  my($subname)='';

  while (!$ok) {
    my $il=indentlevel($line);

    if ($il==$i) {
      # dosubline; # sets $subname
      # print "sub",$line,"\n";
 
      # a line looks like: <char><rest> where char is the action that
      # should happen in the given case
      $line=~/^\s+(\S(.*))$/;
      $actions{$name}.=$1."\n";
      $subname=$2;
    } elsif ($il>$i) {
      $line=sublines($line,$subname);
      next;                             # the new line is already read
    } else {
      return $line; # an illegal decrease might go undetected here
    }
    $line=rnl();
  }
  return $line; # eof... should only happen once
}

sub indentlevel($) {
  $_[0]=~/^(\s+)/;
  my($il)=$1;
  $il=~s/\t/      /;
  return length($il); # indent level
}

sub rnl() { # read new line
  again: {
    $_=<>;
    chop;
    s/#.*$//;
    $ok=eof;
    redo if /^\s*$/ and !$ok;
    return $_;
  }
}

sub sum(@) {
  my($sum);
  for (@_) {
    $sum+=$_;
  }
  return($sum);
}

sub doactions($) {
  for (split(/\n/,$_[0])) {
    /^(\S)(.*)$/ or die 'argh';
    my($act,$rest)=($1,$2);
    if ($act eq '-') {
      delete($disadweights{$rest}) || delete($adweights{$rest});
      				# Hm. depends on disads evaluated first
    } elsif ($act eq '+') {
      my($name,$weight,$val)=split(/:/,$rest);
      my($weights)=(($val>=0)?\%adweights:\%disadweights);
      $$weights{$name} and warn "Name $name multiple in $line";
      $$weights{$name}=$weight;
      $values{$name}=$val;
    } elsif ($act eq '&'){
      my($name,@args)=split(/:/,$rest);
      if ($name eq 'attrib') {
        &attrib($args[0]);
      }
    }
  }
}

sub levelaction($$$) {
  my($name,$weight,$val)=@_;

  # a line looks like: <char><rest> where char is the action that
  # should happen in the given case
  $actions{$name}.="+".$name.":".$weight.":".$val."\n";

}

sub attrib($) {
  $adweights{$_[0]}=700; # hack... should we make the sub 2-valued?
  $values{$_[0]}=$vallist[++$attrib{$_[0]}];
  if ($result{$_[0]}==1) {
    $result{$_[0]}=9; # attributes start at 8
    $resvalue{$_[0]}=-10;
  }
}

sub skilltable($) {
  my(%list);
  for (split('/',$_[0])) {
    for my $l (keys %{$jobskills{$_}}) {
      $list{$l}=0 unless $list{$l}; # no undefineds...
      $list{$l}+=$jobskills{$_}{$l};
    }
  }
  return \%list;
}