diff options
Diffstat (limited to 'crawl-ref/source/util')
-rwxr-xr-x | crawl-ref/source/util/gen-apt.pl | 246 |
1 files changed, 246 insertions, 0 deletions
diff --git a/crawl-ref/source/util/gen-apt.pl b/crawl-ref/source/util/gen-apt.pl new file mode 100755 index 0000000000..d19ec8a279 --- /dev/null +++ b/crawl-ref/source/util/gen-apt.pl @@ -0,0 +1,246 @@ +#! /usr/bin/env perl + +# Generates aptitude table from skills2.cc and the aptitude template file. +# All species names are discovered from skills2.cc and all skill abbreviations +# are discovered from the apt template file, so this script should be +# reasonably insulated from skill and species changes. +# + +use strict; +use warnings; + +my ($target, $template, $expmodfile, $skillfile) = @ARGV; +die "Usage: $0 <target> <template> player.cc skills2.cc\n" + unless ($expmodfile && $skillfile && $template && $target && -r $template + && -r $skillfile && -r $expmodfile); + +my %ABBR_SKILL; +my %SKILL_ABBR; +my %SPECIES_SKILLS; +my @SPECIES; +my %SEEN_SPECIES; + +main(); + +sub main { + load_skill_abbreviations($template); + load_aptitudes($skillfile); + load_expmods($expmodfile); + create_aptitude_file($template, $target); +} + +sub create_aptitude_file { + my ($template, $target) = @_; + open my $outf, '>', $target or die "Can't write $target: $!\n"; + open my $inf, '<', $template or die "Can't read $template: $!\n"; + my $foundmarkers; + my $lastline; + while (<$inf>) { + print $outf $_; + if (/^-{60,}/) { + $foundmarkers = 1; + print $outf aptitude_table($lastline); + + # Repeat separator and headerline under the table. + print $outf $_; + print $outf $lastline; + } + $lastline = $_; + } + die "Could not find skill table sections in $template\n" unless $foundmarkers; +} + +sub abbr_to_skill { + my $abbr = shift; + my $skill = $ABBR_SKILL{$abbr}; + die "Could not find skill corresponding to abbreviation: $abbr\n" + unless $skill; + $skill +} + +sub fix_draco_species { + my ($sp, $rseen) = @_; + if ($sp =~ /^(\w+) Draconian/) { + my $flavour = $1; + if (!$$rseen) { + $$rseen = length($sp); + $sp = "Draconian $flavour"; + } + else { + $sp = sprintf("%*s", $$rseen, $flavour); + } + } + $sp +} + +sub find_skill { + my ($species, $skill) = @_; + my $sk = $SPECIES_SKILLS{$species}{$skill}; + die "Could not find skill $skill for $species\n" unless $sk; + $sk +} + +sub split_species { + my $sp = shift; + if ($sp =~ /^(.*) (.*)$/) { + return ($2, $1); + } + return ($sp, $sp); +} + +sub compare_species { + my ($a, $b) = @_; + return -1 if $a eq 'Human'; + return 1 if $b eq 'Human'; + + my ($abase, $asub) = split_species($a); + my ($bbase, $bsub) = split_species($b); + my $basecmp = $abase cmp $bbase; + return $basecmp if $basecmp; + return $asub cmp $bsub; +} + +sub sort_species { + sort { compare_species($a, $b) } @_ +} + +sub aptitude_table { + chomp(my $headers = shift); + my @skill_abbrevs = $headers =~ /(\S+)/g; + + my $text = ''; + my $seen_draconian_length; + for my $sp (sort_species(@SPECIES)) { + next if $sp eq 'Base Draconian'; + + my $line = ''; + $line .= fix_draco_species($sp, \$seen_draconian_length); + + for my $abbr (@skill_abbrevs) { + my $skill = find_skill($sp, abbr_to_skill($abbr)); + + my $pos = index($headers, " $abbr"); + die "Could not find $abbr in $headers?\n" if $pos == -1; + $pos++; + if ($pos > length($line)) { + $line .= " " x ($pos - length($line)); + } + $line .= sprintf("%*d", length($abbr), $skill); + } + $text .= "$line\n"; + } + $text +} + +sub skill_name { + my $text = shift; + $text =~ tr/a-zA-Z / /c; + $text =~ s/ +/ /g; + $text =~ s/s$//i; + propercase_string($text) +} + +sub load_skill_abbreviations { + my $template = shift; + open my $inf, '<', $template or die "Can't read $template: $!\n"; + my $in_abbr; + while (<$inf>) { + $in_abbr = 1 if /-{15,}/; + next unless $in_abbr; + while (/(\S+(?: \S+)*) {1,3}- {1,3}(\S+(?: \S+)*)/g) { + my $skill = $2; + my $abbr = $1; + $skill = skill_name($skill); + $SKILL_ABBR{$skill} = $abbr; + $ABBR_SKILL{$abbr} = $skill; + } + } + close $inf; + + die "No skill names found in $template\n" unless %SKILL_ABBR; +} + +sub propercase_string { + my $s = lc(shift); + $s =~ s/\b(\w)/\u$1/g; + $s +} + +sub fix_underscores { + my $s = shift; + $s =~ tr/_/ /; + $s +} + +sub load_aptitudes { + my $skillfile = shift; + open my $inf, '<', $skillfile or die "Can't read $skillfile: $!\n"; + my $seen_skill_start; + my $species; + + while (<$inf>) { + last if /\*{40,}/; + if (!$seen_skill_start) { + $seen_skill_start = 1 if /spec_skills\[/; + } + else { + if (m{//\s*SP_(\w+)\s*$}) { + $species = propercase_string(fix_underscores($1)); + die "$skillfile:$.: Repeated skill def for $species.\n" + if $SEEN_SPECIES{$species}; + $SEEN_SPECIES{$species} = 1; + push @SPECIES, $species; + } + if (m{//\s*SK_(\w+)\s*$} && /^\s*\d+/) { + m{//\s*SK_(\w+)\s*$}; + my $skill = skill_name($1); + die "$skillfile:$.: Unknown skill: $skill\n" + unless $SKILL_ABBR{$skill}; + die "$skillfile:$.: Repeated skill def $1 for $species.\n" + if $SPECIES_SKILLS{$species}{$skill}; + ($SPECIES_SKILLS{$species}{$skill}) = /^\s*(\d+)/; + } + } + } + die "Could not find aptitudes for species in $skillfile\n" + unless %SPECIES_SKILLS; +} + +sub species_for_genus { + my $genus = lc(shift); + $genus = 'dwarf' if $genus eq 'dwarven'; + grep(index(lc($_), $genus) != -1, @SPECIES) +} + +sub load_expmods { + my $expmodfile = shift; + open my $inf, '<', $expmodfile or die "Can't read $expmodfile: $!\n"; + + my $inexpmod; + + my @species; + while (<$inf>) { + $inexpmod = 1 if /static.*species_exp_mod/; + next unless $inexpmod; + + if (/GENPC_(\w+)/) { + push @species, species_for_genus($1); + } + if (/SP_(\w+)/) { + push @species, propercase_string(fix_underscores($1)); + } + + if (/return/ && /(\d+)/) { + my $exp = $1; + last if $exp eq '0'; + die "$expmodfile:$.: No species associated with xp mod $1\n" + unless @species; + for my $sp (@species) { + $SPECIES_SKILLS{$sp}{Experience} = $1 * 10; + } + @species = (); + } + } + close $inf; + die "Could not find species exp mods in $expmodfile\n" unless $inexpmod; +} |