#!/usr/bin/perl -w

# A ToME skill point allocation tester.  Run as:
#   tome-skiller [-U] <dump-file-name>
# or:
#   tome-skiler [-U] <race> [<subrace>] <class>
#   tome-skiler [-U] [<subrace>] <race> <class>
# The -U option forces the Udun skill to be accessible; normally it is
# hidden unless it is listed in your character dump or you specify a
# Dark-Priest character.
#
# The display shows all available skills and abilities, the number of skill
# points assigned to each, the number of skill points still available to be
# assigned, and the minimum level required for the current allocation (this
# includes both the skill-level cap and the level needed to accumulate the
# number of points allocated).  Ability lines also display the cost of the
# ability and a status indicator:  (*) if you have selected the ability,
# (+) if you have gained the ability for free by virtue of your level and
# race/class (or if the ability was present in the provided dump file), or
# ( ) if you do not have the ability.
#
# To adjust the skill point allocation, select a skill or ability to modify
# with the up/down arrow keys, and increase or decrease the skill's point
# allocation (or select or deselect the ability) with the left/right arrow
# keys.  Note that ability and skill level prerequisites are enforced when
# selecting abilities, and you cannot select an ability that you have
# already gained by level or that you will gain at a higher level.
#
# There are two additional commands for skill point adjustment:  'z' will
# set a skill's point allocation to zero, and 's' will prompt for a desired
# skill level and set the skill's point allocation to the minimum amount
# necessary to achieve that skill level.
#
# PgUp and PgDown will scroll the skill/ability list if it is longer than
# the screen size; ^L redraws the screen.  'a' toggles the display of
# abilities (from the character screen, like Fighting or Saving Throw) and
# their levels as computed from the current skill levels.  'q' or 'Q'
# quits.  'f' writes the skill point allocation information to the
# specified file.

# Change log:
#
# 2007-05-09:
#   Use File::Spec for pathname manipulation, which will hopefully make the
#   script work better on Windows.
#
# 2005-10-22:
#   Adjustments to properly read character level from 2.3.x character
#   sheets.
#
# 2005-01-10:
#   - Added computation of ability levels from skill levels.  Display is
#     toggled by the 'a' key.
#   - Attempt to detect 2.3.x info files; if found, switch to 2.3 mode,
#     which boosts the skill points per level to 6 and changes the ability
#     formulas appropriately.
#
# 2004-07-03:
#   - Added ability point allocation.
#   - Added 's' and 'z' shortcut commands.
#   - Small display correction.
#
# 2004-02-16:
#   - New command 'f' to dump to file.
#   - Accommodate Necromancer undead form when loading dump files (dump
#     will say "Max Death Points" instead of "Max Hit Points").
#   - Try not to overestimate required character level for an allocation
#     due to 'ripple-effect' skill boosts.
#
# 2004-02-04:
#   - Catch general skill specified by the G:k: lines in p_info.txt.
#   - Hide Udun skill unless we can determine that we should show it, or
#     unless requested via the -U option.
#
# 2004-01-20:
#   Initial release.

use File::Spec;
use Curses;

my %general = ();
my %race = ();
my %subrace = ();
my %class = ();
my %subclass = ();
my %superclass_of = ();
my %sr_pfx = ();
my %fullcase = ();

my %abil_base = ();
my %abil_mod = ();
my @ab_names = ('Disarming', 'Magic Device', 'Saving Throw', 'Stealth',
		'Searching', 'Perception', 'Fighting', 'Bows/Throw');

my @skills = ();
my %depth = ();
my %ripple = ();
my %conflict = ();
my $pts_per_lev = 5;
my $use_23_mode = 0;

my %skills = ();
my $cur_level = 1;
my $start_pts = 0;
my $used_pts = 0;
my $max_pts = 0;
my $show_udun = 0;

my @char = ();
my @abilities = ();
my %abilities = ();

my $N_ROWS;
my $N_SCRL;
my @lines = ();
my $top_line = 0;
my $cur_line = 0;
my $err_msg = '';
my $dump_descr = '';
my $show_abil = 0;

# Directory containing the *_info.txt files.
my $TOME_LIB = '/usr/local/lib/tome/edit';


# prompt() -- Prompt the user for a line of text.
sub prompt ($) {
  my $l = length $_[0];
  my $ret = undef;

  clrtoeol 0, 0;
  addstr 0, 2, $_[0];
  echo;
  getnstr 0, $l + 3, $ret, $COLS - $l - 4;
  noecho;
  return $ret;
}

# lib_file_name() -- Returns the path name of the requested info file, in a
# format appropriate to the system.
sub lib_file_name ($) {
  return File::Spec->catfile($TOME_LIB, $_[0]);
}

# load_player_info() -- Load data from $TOME_LIB/p_info.txt.
sub load_player_info ($) {
  local $_;
  my $full = $_[0];
  my $S = \%general;
  my ($race, $subrace, $class);
  my @ab_target = ();
  my @gods = ();
  my $file = lib_file_name 'p_info.txt';

  open IN, "<$file" or die "Cannot open $file:  $!\n";
  while (<IN>) {
    chomp;
    if (/^C:X:0:0:0:0:0:0:0:0$/) {
      # Amazingly Dodgy Hack(TM):  No class modifiers means we're reading a
      # 2.3.x p_info.txt, and in 2.3.x, we get 6 skill points per level.
      $use_23_mode = 1;
      $pts_per_lev = 6;
      next;
    }
    if (/^R:N:\d+:(.+)$/) {
      # New race.
      $race = lc $1;
      @ab_target = (0, $race);
      $fullcase{$race} = $1;
      $S = $race{$race} = {};
      next;
    }
    if (/^S:N:\d+:(.+)$/) {
      # New class.
      $subrace = lc $1;
      @ab_target = (1, $subrace);
      $fullcase{$subrace} = $1;
      $S = $subrace{$subrace} = {};
      next;
    }
    if (/^S:D:([AB]):/ && $subrace) {
      # Prefix/suffix indicator for subrace.
      $sr_pfx{$subrace} = ($1 eq 'B' ? 1 : 0);
      next;
    }
    if (/^C:N:\d+:(.+)$/) {
      # New class.
      $class = lc $1;
      @ab_target = (2, $class);
      $fullcase{$class} = $1;
      $S = $class{$class} = {};
      next;
    }
    if (/^C:a:N:(.+)$/) {
      # New subclass.
      my $subclass = lc $1;
      @ab_target = (3, $subclass);
      $fullcase{$subclass} = $1;
      $S = $subclass{$subclass} = {};
      $superclass_of{$subclass} = $class;
      next;
    }
    if (/^C:a:g:(.+)$/) {
      # A god this subclass can worship.
      push @gods, $1;
      next;
    }
    if (/:k:([-+=%]\d+):([-+=%]\d+):(.+)$/ && $full) {
      # Skill modifiers for the current race/subrace/class/subclass.  We
      # ignore these if we're going to be loading a character dump later.
      my ($start, $mod, $name) = ($1, $2, $3);
      $$S{$name} = { start => $start, mod => $mod };
    }
    if (/:b:(\d+):(.+)$/) {
      # Ability gained by this race/subrace/class/subclass at the specified
      # level.
      my ($lev, $abil) = ($1, $2);
      push @{$abilities{$abil}{gain_at}}, [ @ab_target, $lev ];
    }
    if (/^([RSC]):K:(.*)$/) {
      # Angband ability base levels by race, subrace and class.
      my ($which, $list) = ($1, $2);
      $which = ($which eq 'R' ? $race : $which eq 'S' ? $subrace : $class);
      $abil_base{$which} = [ split ':', $list ];
      next;
    }
    if (/^C:X:(.*)$/) {
      # Angband ability class modifiers.
      my $list = $1;
      $abil_mod{$class} = [ split ':', $list ];
      next;
    }
  }
  close IN;

  # If Melkor is this subclass's only choice of god to worship, then we
  # know we need to unhide the Udun skill.
  if (scalar @gods == 1 && $gods[0] eq 'Melkor Bauglir' && $full) {
    $show_udun = 1;
  }
}

# load_ability_info() -- Load data from $TOME_LIB/ab_info.txt.
sub load_ability_info () {
  local $_;
  my $A = undef;
  my $file = lib_file_name 'ab_info.txt';

  open IN, "<$file" or die "Cannot open $file:  $!\n";
  while (<IN>) {
    chomp;
    if (/^N:\d+:(.*)$/) {
      # New ability.
      push @abilities, $1;
      $A = $abilities{$1} = {
	name => $1,
	cost => 0,
	base => 0,
	selected => 0,
	gain_at => [],
	need_sk => [],
	need_ab => []
      };
      next;
    }
    if (/^I:(\d+)$/) {
      # Cost of the current ability.
      $$A{cost} = $1;
      next;
    }
    if (/^k:(\d+):(\S+)$/) {
      # Skill-level prerequisit for the current ability.
      push @{$$A{need_sk}}, [ $2, $1 ];
      next;
    }
    if (/^a:(.*\S)$/) {
      # Ability prerequisite for the current ability.
      push @{$$A{need_ab}}, $1;
      next;
    }
  }
  close IN;
}

# load_skill_info() -- Load data from $TOME_LIB/s_info.txt
sub load_skill_info () {
  local $_;
  # Skill hierarchy information is collected here.
  my %tree = ( Main => { lvl => 0, children => [] } );
  my $file = lib_file_name 's_info.txt';

  open IN, "<$file" or die "Cannot open $file:  $!\n";
  while (<IN>) {
    chomp;
    if (/^f:(.+):(.+)%(\d+)$/) {
      # A "ripple-effect" line -- how much to increase the destination
      # skill per point spent in the source skill.
      my ($src, $dest, $pct) = ($1, $2, $3);
      $ripple{$src} ||= {};
      $ripple{$src}{$dest} = $pct;
      next;
    }
    if (/^E:(.+):(.+)$/) {
      # Exclusion lines; we prevent points from being allocated to both
      # skills simultaneously.
      my ($a, $b) = ($1, $2);
      $conflict{$a} ||= {};
      $conflict{$b} ||= {};
      $conflicts{$a}{$b} = $conflicts{$b}{$a} = 1;
    }
    if (/^T:(.+):(.+)$/) {
      # Hierarchy information.
      my ($parent, $child) = ($1, $2);
      die "No entry for parent skill $parent in skill tree\n"
	if !exists($tree{$parent});
      die "Conflicting entry for child skill $child in skill tree\n"
	if exists $tree{$child};
      push @{$tree{$parent}{children}}, $child;
      $tree{$child} = { lvl => $tree{$parent}{lvl} + 1, children => [] };
      next;
    }
  }
  close IN;

  # We construct the skill list in depth-first order.  We don't really need
  # to keep any of the rest of the tree information, except the depth
  # itself.
  my $dfs = sub {
    my ($name, $fn) = @_;
    push @skills, $name if $name ne 'Main';
    for my $child (@{$tree{$name}{children}}) { &$fn($child, $fn) }
  };
  &$dfs('Main', $dfs);
  %depth = map { ($_ => $tree{$_}{lvl}) } @skills;
}

# load_player_dump() -- Load and extract useful information from a
# character dump, and set up for the main loop.
sub load_player_dump ($) {
  local $_;
  my ($name, $race, $class);
  $cur_level = 0;	# input check

  open IN, "<$_[0]" or die "Cannot open $_[0]:  $!\n";
  while (<IN>) {
    chomp;
    if (/Name  : (.+?)\s+Age/) { $name = $1; next }
    if (/Race  : (.+?)\s+Weight/) { $race = $1; next }
    if (/Class : (.+?)\s+Social/) { $class = $1; next }
    if (/Level\s+(\d+)\s+(?:Max )?(?:Hit|Death) Points/) { $cur_level = $1; next }
    if (/Skills \(points left: (\d+)\)/) { $start_pts = $1; next }
    if (/^\s+[-.] (\S+)\s+(\d+\.\d{3}) \[(\d+\.\d{3})\]\s*$/) {
      my ($skill, $level, $mod) = ($1, $2, $3);
      warn "??? $skill\n" and next if !exists($skills{$skill});
      $show_udun = 1 if $skill eq 'Udun' && $mod > 0;
      my $S = $skills{$skill};
      $$S{base} = $$S{level} = int($level*1000);
      $$S{mod} = int($mod*1000);
      next;
    }
    if (/^ \* (.*\S)\s*$/) {
      my $abil = $1;
      warn "??? $abil\n" and next if !exists($abilities{$abil});
      $abilities{$abil}{base} = 1;
      next;
    }
  }
  close IN;

  warn "Cannot read name from character sheet\n" if !defined $name;
  warn "Cannot read race/subrace from character sheet\n" if !defined $race;
  warn "Cannot read class from character sheet\n" if !defined $class;
  warn "Cannot read level from character sheet\n" if $cur_level == 0;
  sleep 1 if !defined $race || !defined $class || !defined $class ||
	     $cur_level == 0;

  $dump_descr = "dump of $name, the level-$cur_level $race $class";

  my ($r, $sr) = split ' ', lc $race;
  ($r, $sr) = ($sr, $r) if $sr && exists $race{$sr};
  $class = lc $class;
  @char = ($r, $sr, $superclass_of{$class}, $class);
}

# apply_skill_mod_aux() -- Apply an adjustment to a skill base amount or
# modifier.
sub apply_skill_mod_aux (\$$) {
  my ($val, $mod) = @_;
  die "Malformed skill mod '$mod'\n" if $mod !~ /^([-+=%])(\d+)$/;
  my ($type, $amt) = ($1, $2);

  $$val += $amt if $type eq '+';
  $$val -= $amt if $type eq '-';
  $$val = $amt if $type eq '=';
  $$val = int($$val * $amt / 100) if $type eq '%';
}

# apply_skill_mod() -- Apply a modifier to existing skill information.
sub apply_skill_mod ($$) {
  my ($skill, $mod) = @_;
  apply_skill_mod_aux $skills{$skill}{base}, $$mod{start};
  apply_skill_mod_aux $skills{$skill}{mod}, $$mod{mod};
}

# tabula_rasa() -- Set up for the main loop based on the race/subrace/class
# information from the command line.
sub tabula_rasa () {
  my @args = @ARGV;
  splice @args, 1, 0, '' if scalar @args == 2;
  my ($race, $subrace, $subclass) = map { lc $_ } @args;

  # Allow for prefix subraces.
  if ($subrace && exists $subrace{$race} && exists $race{$subrace}) {
    ($race, $subrace) = ($subrace, $race);
    @args[(0,1)] = @args[(1,0)];
  }

  die "'$args[0]' is not a recognized race\n" if !exists($race{$race});
  die "'$args[1]' is not a recognized subrace\n"
    if $subrace && !exists($subrace{$subrace});
  die "?1? @{[ keys %subclass ]}\n" if !exists($subclass{$subclass});
  die "?2? @{[ keys %superclass_of ]}\n" if !exists($superclass_of{$subclass});
  die "'$args[2]' is not a recognized class\n"
    if !exists($subclass{$subclass}) || !exists($superclass_of{$subclass});

  my $class = $superclass_of{$subclass};

  # Apply all relevant skill adjustments.
  for my $skill (keys %general) {
    apply_skill_mod $skill, $general{$skill};
  }
  for my $skill (keys %{$race{$race}}) {
    apply_skill_mod $skill, $race{$race}{$skill};
  }
  if ($subrace) {
    for my $skill (keys %{$subrace{$subrace}}) {
      apply_skill_mod $skill, $subrace{$subrace}{$skill};
    }
  }
  for my $skill (keys %{$class{$class}}) {
    apply_skill_mod $skill, $class{$class}{$skill};
  }
  for my $skill (keys %{$subclass{$subclass}}) {
    apply_skill_mod $skill, $subclass{$subclass}{$skill};
  }

  for my $S (values %skills) { $$S{level} = $$S{base} }

  my @order = ($race, $subrace, $subclass);
  @order = ($subrace, $race, $subclass) if $subrace && $sr_pfx{$subrace};
  $dump_descr = join ' ', map { $fullcase{$_} } grep { $_ } @order;
  $dump_descr = "generic $dump_descr";
  @char = ($race, $subrace, $class, $subclass);
}

# req_level() -- Returns the character level that would be necessary to
# achieve the current skill point allocation.
sub req_level () {
  my $req_level = $cur_level;
  $req_level += int(($used_pts - $start_pts + $pts_per_lev - 1)/$pts_per_lev)
    if $used_pts > $start_pts;
  for my $skill (@skills) {
    my $S = $skills{$skill};
    my $lvl = $$S{base} + $$S{mod}*$$S{points};
    $lvl = int(($lvl - ($lvl%1000))/1000) - 4;
    $req_level = $lvl if $req_level < $lvl;
  }
  return $req_level;
}

# lev_gain_abil() -- Returns the character level, if any, at which the
# specified ability is automatically gained.
sub lev_gain_abil ($) {
  die "No such ability '$_[0]'\n" unless exists $abilities{$_[0]};
  my $thresh = $abilities{$_[0]}{gain_at};
  my $lev = 9999;
  for my $th (@$thresh) {
    my @type = qw(race subrace class subclass);
    next unless $$th[1] eq $char[$$th[0]];
    $lev = $$th[2] if $lev > $$th[2];
  }
  return $lev;
}

# has_abil() -- Returns true if the specified ability is enabled in the
# current point allocation, whether by user selection, character dump
# information, or automatic gain by level.
sub has_abil ($) {
  die "No such ability '$_[0]'\n" unless exists $abilities{$_[0]};
  my $A = $abilities{$_[0]};
  return $$A{base} || $$A{selected} || lev_gain_abil $_[0] <= req_level;
}

# check_abil_req() -- Returns an empty string if all prerequisites for the
# specified ability have been satisfied; if not, returns an appropriate
# error message.
sub check_abil_req ($) {
  die "No such ability '$_[0]'\n" unless exists $abilities{$_[0]};
  my $A = $abilities{$_[0]};
  for my $sk_need (@{$$A{need_sk}}) {
    my ($sk, $need) = @$sk_need;
    return "Need $sk level $need" if $skills{$sk}{level} < $need*1000;
  }
  for my $ab (@{$$A{need_ab}}) {
    return "  Need $ab ability" unless has_abil $ab;
  }
  return '';
}

# update_skills() -- Calculate skill levels based on the current point
# allocation.
sub update_skills () {
  # First assign normal points.
  for my $skill (@skills) {
    my $S = $skills{$skill};
    $$S{level} = $$S{base} + $$S{mod}*$$S{points};
  }
  # Then do cross-skill adjustments.
  for my $s1 (@skills) {
    for my $s2 (@skills) {
      next if $s1 eq $s2;
      if (exists $ripple{$s1}{$s2}) {
	my $S1 = $skills{$s1};
	my $S2 = $skills{$s2};
	$$S2{level} += int($$S1{points} * $$S2{mod} * $ripple{$s1}{$s2} / 100);
      }
    }
  }
  # Cap skill levels above and below.
  for my $skill (@skills) {
    my $S = $skills{$skill};
    $$S{level} = 0 if $$S{level} < 0 && !$use_23_mode;
    $$S{level} = 50000 if $$S{level} > 50000;
  }
}

# select_ability() -- Attempt to select or deselect the specified ability
# at the user's request.  Returns 1 if successful, 0 if unsuccessful.
sub select_ability ($$) {
  my ($name, $on) = @_;
  my $A = $abilities{$name};
  my $req_level = req_level;
  my $gain_level = lev_gain_abil $name;

  return 0 if $$A{selected} == $on;
  if ($on) {
    # Make sure we have enough skill points.
    if ($used_pts + $$A{cost} > $max_pts) {
      $err_msg = "Need $$A{cost} skill points";
      return 0;
    }
    # Make sure we don't already have the skill, and won't get it for free.
    if ($$A{base} || $req_level >= $gain_level) {
      $err_msg = 'You already have this ability';
      return 0;
    }
    if ($gain_level <= 50) {
      $err_msg = "You will gain $name at level $gain_level";
      return 0;
    }
    # Make sure we meet all the requirements.
    $err_msg = check_abil_req $name;
    return 0 if $err_msg;
  }

  $$A{selected} = $on;
  $used_pts += $$A{cost} * ($on ? 1 : -1);
  return 1;
}

# adjust_skill() -- Attempt to adjust the point allocation of the specified
# skill by the specified amount.  Returns 1 if successful, 0 if unsuccessful.
sub adjust_skill ($$) {
  my ($name, $amt) = @_;
  my $S = $skills{$name};
  # Check all the boundary cases.
  return 0 if $used_pts + $amt > $max_pts || $used_pts + $amt < 0 ||
	      $$S{points} + $amt < 0 || ($$S{level} >= 50000 && $amt > 0) ||
	      $$S{mod} == 0;
  # Make sure we don't have any points allocated to a conflicting skill.
  if (exists $conflict{$name} && $amt > 0) {
    for my $cf (keys %{$conflict{$name}}) {
      next if $skills{$cf}{points} == 0;
      $err_msg = "Cannot increase $name while points are in $cf";
      return 0;
    }
  }

  # Do the adjustment.
  $used_pts += $amt;
  $$S{points} += $amt;
  update_skills;

  # Deselect any abilities whose skill prerequisites are no longer
  # satisfied.
  my @ab_gone = ();
  for my $abil (@abilities) {
    next unless $abilities{$abil}{selected};
    push @ab_gone, $abil if check_abil_req $abil ne '';
  }
  if (scalar @ab_gone > 0) {
    my $y = (scalar @ab_gone == 1 ? 'y' : 'ies');
    my $gone = join ', ', @ab_gone;
    $err_msg = "Deselecting abilit$y $gone";
    for my $abil (@ab_gone) { select_ability $abil, 0 }
  }

  return 1;
}

# skill_target() -- Prompts the user for a skill level target and attempts
# to adjust the specified skill's point allocation to hit that target.
# Returns 1 if successful, 0 if unsuccessful.
sub skill_target ($) {
  my $name = $_[0];
  my $S = $skills{$name};
  return 0 if $$S{mod} == 0;
  my $amt = 0;

  my $target = prompt 'Target skill level:';
  return 1 if !$target;
  if ($target !~ /^\d{1,2}(\.\d{0,3})?$/) {
    $err_msg = "Malformed skill target '$target'";
    return 0;
  }
  $target = 50000 if $target > 50000;

  if ($target*1000 > $$S{level}) {
    # Adjust up.
    my $delta = $target*1000 - $$S{level};
    $amt = int($delta/$$S{mod}) + ($delta % $$S{mod} ? 1 : 0);
  }
  elsif ($target*1000 < $$S{level}) {
    # Adjust down.
    $amt = -int(($$S{level} - $target*1000)/$$S{mod});
  }
  return 1 if $amt == 0;

  # Constrain the adjustment amount as necessary.
  $amt = $max_pts - $used_pts if $used_pts + $amt > $max_pts;
  $amt = -$used_pts if $used_pts + $amt < 0;
  $amt = -$$S{points} if $$S{points} + $amt < 0;

  return adjust_skill $name, $amt;
}

# fmt_skill_val() -- Formats a skill level or skill modifier in the usual
# ToME display form.  The optional argument specifies whether the returned
# string should be padded to the full NN.NNN width if necessary.
sub fmt_skill_val ($;$) {
  my ($v, $pad) = @_;
  $v = 50000 if $v > 50000;
  my $sgn = ' ';
  ($v, $sgn) = (-$v, '-') if $v < 0;
  my $f = $v % 1000;
  my $i = int(($v - $f)/1000);
  if ($pad) {
    $i = sprintf '%3s', "$sgn$i";
  } else {
    $i = $sgn . $i;
  }
  $f = sprintf '%03d', $f;
  return "$i.$f";
}

# skill_line() -- Returns a line describing the specified skill, its
# current level, modifier and point allocation.  The optional parameter
# indicates screen mode, which will need to be adjusted for width if
# abilities are being displayed.
# display or printing.
sub skill_line ($;$) {
  my ($name, $screen) = @_;
  my $W = ($screen && $show_abil ? 35 : 50);
  my $S = $skills{$name};
  my $wid = $depth{$name}*2 + 2;
  my $pad = ' ' x $wid;
  $wid = $W - $wid;
  my $lvl = fmt_skill_val($$S{level}, 1);
  my $mod = fmt_skill_val($$S{mod});
  my $pts = "($$S{points})";
  return sprintf $pad.'%-'.$wid.'s%5s %s [%s]', $name, $pts, $lvl, $mod;
}

# ability_line() -- Returns a line describing the specified ability, its
# cost and selection status.  Suitable for screen display or printing.
sub ability_line ($) {
  my $name = $_[0];
  my $A = $abilities{$name};
  my $has = ($$A{selected} ? '*' : has_abil $name ? '+' : ' ');
  my $pts = $$A{selected} ? "($$A{cost})" : '(0)';
  return sprintf '    %-47s%4s    (%s)  [%2d]', $name, $pts, $has, $$A{cost};
}

# abil_line() -- Returns a line describing the current level of the
# specified Angband ability, computed from current skill levels.  Will be
# combined with the output from skill_line() in display mode, or listed
# after them in print mode.
sub __($$) { return int(($_[0]*$_[1])/50000) }
my @adj_sav = (0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 4,
	       4, 5, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19);
sub abil_line ($) {
  my $which = $_[0];
  my ($val, $CM) = (0, 0);

  if (!$use_23_mode) {
    my ($race, $subrace, $class, $subclass) = @char;
    $val = $abil_base{$race}[$which] + $abil_base{$class}[$which];
    $val += $abil_base{$subrace}[$which] if $subrace;
    $CM = $abil_mod{$class}[$which];
  }

  if ($which == 0) {	# Disarming
    if ($use_23_mode) {
      $val += __($skills{Disarming}{level}, 75);
    } else {
      $val += __($skills{Disarming}{level}, $CM*5);
    }
  }
  if ($which == 1) {	# Magic Device
    if ($use_23_mode) {
      $val += __($skills{'Magic-Device'}{level}, 20) +
	     __($skills{'Magic-Device'}{level}, 150);
    } else {
      $val += __($skills{'Magic-Device'}{level}, 20) +
	      __($skills{'Magic-Device'}{level}, $CM*10);
    }
  }
  if ($which == 2) {	# Saving Throw
    if ($use_23_mode) {
      $val += 10 + $adj_sav[__($skills{Spirituality}{level}, 37)] +
	      __($skills{Spirituality}{level}, 75);
    } else {
      $val += $adj_sav[__($skills{Spirituality}{level}, 37)] +
	      __($skills{Spirituality}{level}, $CM*5);
    }
  }
  if ($which == 3) {	# Stealth
    if ($use_23_mode) {
      $val += 1 + __($skills{Stealth}{level}, 25);
    } else {
      $val += 1 + __($skills{Stealth}{level}, $CM*5) +
		  __($skills{Stealth}{level}, 25);
    }
  }
  if ($which == 4) {	# Searching
    if ($use_23_mode) {
      $val += __($skills{Sneakiness}{level}, 35);
    } else {
      $val += __($skills{Sneakiness}{level}, $CM*5) +
	      __($skills{Sneakiness}{level}, 50);
    }
  }
  if ($which == 5) {	# Perception
    if ($use_23_mode) {
      $val += __($skills{Sneakiness}{level}, 25);
    } else {
      $val += __($skills{Sneakiness}{level}, $CM*5) +
	      __($skills{Sneakiness}{level}, 50);
    }
  }
  if ($which == 6) {	# Fighting
    # Questionable Hack(TM):  We assume the user won't invest skill points
    # in both Barehand-combat and Bearform-combat, and that if skill points
    # are invested in one of them, the user wants to use the corresponding
    # melee style instead of Weaponmastery.
    my $mastery = 'Weaponmastery';
    $mastery = 'Barehand-combat' if $skills{'Barehand-combat'}{points} > 0;
    $mastery = 'Bearform-combat' if $skills{'Bearform-combat'}{points} > 0;
    my $adj = int((7*__($skills{$mastery}{level}, 50) +
		   3*__($skills{Combat}{level}, 50))/10);
    if ($use_23_mode) {
      $val += int((50*$adj)/10);
    } else {
      $val += int(($CM*$adj)/10);
    }
  }
  if ($which == 7) {	# Bows/Throw
    my $adj = int((7*__($skills{Archery}{level}, 50) +
		   3*__($skills{Combat}{level}, 50))/10);
    if ($use_23_mode) {
      $val += int((50*$adj)/10);
    } else {
      $val += int(($CM*$adj)/10);
    }
  }

  return sprintf '   %-12s   %3d', $ab_names[$which], $val;
}

# update_display() -- Redraw the screen to reflect the current state.
sub update_display () {
  my $req_level = req_level;

  erase;
  addstr 0, 2, "Used $used_pts of $max_pts points";
  addstr 0, 27, "[req. level $req_level]";
  if ($err_msg) {
    attrset A_BOLD;
    addstr 1, 4, $err_msg;
    attrset A_NORMAL;
    $err_msg = '';
  }

  @lines = ((map { skill_line $_, 1 } @skills), '',
	    (map { ability_line $_ } @abilities));
  if ($show_abil) {
    die "Too few skills to show abilities\n" if scalar @skills < 8;
    for my $i(0..7) { $lines[$i] .= abil_line $i }
  }

  for (my $i = 0; $i < $N_ROWS && $i + $top_line <= $#lines; $i++) {
    my $l = $i + $top_line;
    if ($l == $cur_line) {
      attron A_REVERSE;
      addstr $i + 2, 0, ' ' x $COLS;
    }
    attrset A_DIM if $l <= $#skills && $skills{$skills[$l]}{mod} == 0;
    addstr $i + 2, 0, $lines[$l];
    attrset A_NORMAL;
  }
  if ($top_line > 0) { addstr 2, 1, '^^'; addstr 2, 77, '^^'; }
  if ($top_line + $N_ROWS - 1 < $#lines) {
    addstr $LINES-1, 1, 'vv'; addstr $LINES-1, 77, 'vv';
  }
  move $LINES - 1, $COLS - 1;
  refresh;
}

# start_curses() -- Set text screen to appropriate Curses mode.
sub start_curses () {
  initscr;
  cbreak;
  noecho;
  keypad 1;
  $N_ROWS = $LINES - 2;
  $N_SCRL = int($N_ROWS/2);
}

# end_curses() -- Return text screen to original mode.
sub end_curses () {
  clear;
  refresh;
  endwin;
}

# write_skills() -- Prompt the user for a filename and write a description
# of the current skill point allocation to the specified file.
sub write_skills () {
  my $fnam = prompt 'File name:';
  return if !$fnam;
  $fnam =~ s#^~/#$ENV{HOME}/#;
  unless (open OUT, ">$fnam") {
    $err_msg = "Cannot create ${fnam}:  $!";
    return;
  }

  print OUT "Based on $dump_descr\n";
  printf OUT '  %-25s[req. level %d]'."\n", 
	     "Used $used_pts of $max_pts points", req_level;
  for my $skill (@skills) { print OUT skill_line($skill) . "\n" }
  print OUT "\n";
  for my $abil (@abilities) { print OUT ability_line($abil) . "\n" }
  print OUT "\n";
  for my $i (0..7) { print OUT abil_line($i) . "\n" }
  close OUT;
}

# scroll_by() -- Scroll the screen by the specified number of lines.
sub scroll_by ($) {
  $top_line += $_[0];
  $top_line = 0 if $top_line < 0;
  $top_line = $#lines + 1 - $N_ROWS if $top_line > $#lines + 1 - $N_ROWS;
  $cur_line = $top_line + 1
    if $cur_line < $top_line && $top_line == $#skills + 1;
  $cur_line = $top_line if $cur_line < $top_line;
  $cur_line = $top_line + $N_ROWS - 2
    if $cur_line >= $top_line + $N_ROWS &&
       $top_line + $N_ROWS - 1 == $#skills + 1;
  $cur_line = $top_line + $N_ROWS - 1 if $cur_line >= $top_line + $N_ROWS;
}

# handle_char() -- Process input character from the user and perform the
# requested action.
sub handle_char ($) {
  my $c = $_[0];

  return 1 if $c eq 'q' || $c eq 'Q' || $c eq "\033";
  if ($c eq "\f") {
    # Refresh screen.
    clear;
    return 0;
  }
  if ($c eq 'f') {
    # Write skill point allocation to file.
    write_skills;
    return 0;
  }
  if ($c eq 's') {
    # Adjust skill point allocation to hit specified target.
    beep unless $cur_line <= $#skills && skill_target $skills[$cur_line];
    return 0;
  }
  if ($c eq 'z') {
    # Set point allocation to zero for this skill.
    if ($cur_line <= $#skills) {
      my $skill = $skills[$cur_line];
      adjust_skill $skill, -$skills{$skill}{points} or beep;
    } else {
      beep;
    }
    return 0;
  }
  if ($c eq 'a') {
    # Toggle display of Angband abilities.
    $show_abil = !$show_abil;
    return 0;
  }
  return 0 if $c !~ /^\d\d+$/;
  if ($c == KEY_UP) {
    # Up one line.
    (beep, return 0) if $cur_line <= 0;
    $cur_line--;
    $cur_line-- if $cur_line == $#skills + 1;
    scroll_by -$N_SCRL if $cur_line < $top_line;
    return 0;
  }
  if ($c == KEY_DOWN) {
    # Down one line.
    (beep, return 0) if $cur_line >= $#lines;
    $cur_line++;
    $cur_line++ if $cur_line == $#skills + 1;
    scroll_by $N_SCRL if $cur_line >= $top_line + $N_ROWS;
    return 0;
  }
  if ($c == KEY_LEFT) {
    # Decrease skill allocation or deselect ability.
    if ($cur_line <= $#skills) {
      adjust_skill($skills[$cur_line], -1) or beep;
    } elsif ($cur_line >= $#skills + 2) {
      select_ability($abilities[$cur_line - $#skills - 2], 0) or beep;
    } else {
      $err_msg = '??? cursor shouldn\'t be on this line...';
      beep;
    }
    return 0;
  }
  if ($c == KEY_RIGHT) {
    # Increase skill allocation or select ability.
    if ($cur_line <= $#skills) {
      adjust_skill($skills[$cur_line], 1) or beep;
    } elsif ($cur_line >= $#skills + 2) {
      select_ability($abilities[$cur_line - $#skills - 2], 1) or beep;
    } else {
      $err_msg = '??? cursor shouldn\'t be on this line...';
      beep;
    }
    return 0;
  }
  if ($c == KEY_PPAGE) {
    # Up half-page.
    (beep, return 0) if $top_line <= 0;
    scroll_by -$N_SCRL;
    return 0;
  }
  if ($c == KEY_NPAGE) {
    # Down half-page.
    (beep, return 0) if $top_line + $N_ROWS >= $#lines + 1;
    scroll_by $N_SCRL;
    return 0;
  }
  beep;
  return 0;
}

# mainloop() -- The primary command execution loop.
sub mainloop () {
  for (;;) {
    update_display;
    last if handle_char(getch);
  }
}



if (scalar @ARGV > 0 && $ARGV[0] eq '-U') { $show_udun = 1; shift @ARGV }
load_skill_info;
load_ability_info;
for my $skill (@skills) {
  $skills{$skill} = { points => 0, base => 0, level => 0, mod => 0 };
}
if (scalar @ARGV == 1) {
  # Load a character dump.
  load_player_info 0;
  load_player_dump $ARGV[0];
  die "Could not find player level in dump file $ARGV[0]\n" if !$cur_level;
} elsif (scalar @ARGV == 2 || scalar @ARGV == 3) {
  # Use race/subrace/class from the command line.
  load_player_info 1;
  tabula_rasa;
} else {
  die "usage: $0 <dump-file> | ( <race> [<subrace>] <class> )\n";
}
$skills{Udun}{mod} = 0 if !$show_udun;
@skills = grep { $skills{$_}{mod} > 0 } @skills;
$max_pts = $start_pts + $pts_per_lev*(50 - $cur_level);

start_curses;
mainloop;
end_curses;