mirror of
https://github.com/wesnoth/wesnoth
synced 2025-04-26 02:51:40 +00:00
292 lines
7.3 KiB
Perl
Executable File
292 lines
7.3 KiB
Perl
Executable File
use wml;
|
|
|
|
#helper functions we want eval to be able to see
|
|
sub decimal($)
|
|
{
|
|
sprintf "%.2f", $_[0];
|
|
}
|
|
|
|
my $expression = '';
|
|
my @sortby = ();
|
|
my @filter = ();
|
|
my @where = ();
|
|
my @heading = ();
|
|
my @fold = ();
|
|
|
|
while(my $arg = shift @ARGV) {
|
|
if($arg eq '--sortby') {
|
|
my $sortby = shift @ARGV or die "need argument to --sortby option";
|
|
unshift @sortby, $sortby;
|
|
} elsif($arg eq '--filter') {
|
|
my $filter = shift @ARGV or die "need argument to --filter option";
|
|
push @filter, $filter;
|
|
} elsif($arg eq '--where') {
|
|
my $where = shift @ARGV or die "need argument to --where option";
|
|
push @where, $where;
|
|
} elsif($arg eq '--prelude') {
|
|
my $prelude = shift @ARGV or die "need argument to --prelude option";
|
|
open PRELUDE, "<$prelude" or die "could not open prelude '$prelude'";
|
|
my @prelude = <PRELUDE>;
|
|
close PRELUDE;
|
|
|
|
push @where, (join '',@prelude);
|
|
} elsif($arg eq '--heading') {
|
|
my $heading = shift @ARGV or die "need argument to --heading option";
|
|
@heading = split ',', $heading or die "could not evaluate heading: $!";
|
|
} elsif($arg eq '--fold') {
|
|
my $fold = shift @ARGV or die "need argument to --fold option";
|
|
push @fold, $fold;
|
|
} elsif($arg eq '--help') {
|
|
print "Wesnoth Unit Analysis Tool. Usage: $0 [options] <expression>
|
|
<expression> is a Perl expression which will be evaluated for each unit with the results output. There is a set of parentheses assumed around <expression>, so a comma-separated list of expressions is valid.
|
|
A valid Wesnoth cache must be provided on stdin.
|
|
Options:
|
|
--sortby: sort by the given expression
|
|
--filter: evaluates the given expression, and will only display results for the unit if the filter evaluates to true
|
|
--where: executes the given code before executing any other expression for each unit
|
|
--prelude: like --where, but opens up a given file and runs the script in it.
|
|
";
|
|
} else {
|
|
die "unrecognized argument '$arg'. Use --help for help." if $expression;
|
|
$expression = $arg;
|
|
}
|
|
}
|
|
|
|
die "must give an expression to evaluate" unless $expression;
|
|
|
|
my $text = '';
|
|
read STDIN, $text, 10000000;
|
|
my $doc = &wml::read_binary([],$text) or die "could not read document";
|
|
$text = '';
|
|
|
|
my $units = 0;
|
|
foreach my $item (@{$doc->{'children'}}) {
|
|
if($item->{'name'} eq 'units') {
|
|
$units = $item;
|
|
last;
|
|
}
|
|
}
|
|
|
|
die "could not find [units] section" unless $units;
|
|
|
|
my %movetypes = ();
|
|
my @units = ();
|
|
my @results = ();
|
|
my $columns = 0;
|
|
|
|
foreach my $item (@{$units->{'children'}}) {
|
|
if($item->{'name'} eq 'unit') {
|
|
push @units, $item;
|
|
} elsif($item->{'name'} eq 'movetype') {
|
|
$movetypes{$item->{'attr'}->{'name'}} = $item;
|
|
}
|
|
}
|
|
|
|
foreach my $unit (@units) {
|
|
my $unitname = $unit->{'attr'}->{'id'};
|
|
my $movetype = $unit->{'attr'}->{'movement_type'};
|
|
$movetype = $movetypes{$movetype};
|
|
|
|
if($movetype) {
|
|
foreach my $item (@{$movetype->{'children'}}) {
|
|
&apply_unit_movetype($unit,$item);
|
|
}
|
|
}
|
|
|
|
foreach my $item (@{$unit->{'children'}}) {
|
|
&apply_unit_movetype($unit,$item);
|
|
}
|
|
}
|
|
|
|
sub apply_unit_movetype
|
|
{
|
|
my ($unit,$mod) = @_;
|
|
my %attr = %{$mod->{'attr'}};
|
|
if($mod->{'name'} eq 'movement_costs') {
|
|
while(my ($name,$value) = each(%attr)) {
|
|
$unit->{'attr'}->{'move_' . $name} = $value;
|
|
}
|
|
} elsif($mod->{'name'} eq 'defense') {
|
|
while(my ($name,$value) = each(%attr)) {
|
|
$unit->{'attr'}->{'defense_' . $name} = $value;
|
|
}
|
|
} elsif($mod->{'name'} eq 'resistance') {
|
|
while(my ($name,$value) = each(%attr)) {
|
|
$unit->{'attr'}->{'resist_' . $name} = $value;
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach my $filter (@filter) {
|
|
my @new_units = ();
|
|
foreach my $unit (@units) {
|
|
my $res = &evaluate_expression($unit,$filter);
|
|
next unless $res;
|
|
my $pass = 1;
|
|
foreach my $item (@$res) {
|
|
unless($item) {
|
|
$pass = 0;
|
|
last;
|
|
}
|
|
}
|
|
|
|
push @new_units, $unit if $pass;
|
|
}
|
|
|
|
@units = @new_units;
|
|
}
|
|
|
|
foreach my $sortby (@sortby) {
|
|
@units = sort {
|
|
my ($resa,$resb) = (&evaluate_expression($a,$sortby),
|
|
&evaluate_expression($b,$sortby));
|
|
return 0 unless $resa or $resb;
|
|
return -1 unless $resa;
|
|
return 1 unless $resb;
|
|
while(@$resa or @$resb) {
|
|
my ($itema,$itemb) = (shift @$resa,shift @$resb);
|
|
my $res = &compare_values($itema,$itemb);
|
|
return $res if $res;
|
|
}
|
|
return 0;
|
|
} @units;
|
|
}
|
|
|
|
my $nfields = 0;
|
|
foreach my $unit (@units) {
|
|
my $res = &evaluate_expression($unit,"$expression");
|
|
push @results, $res;
|
|
$nfields = scalar(@$res) if scalar(@$res) > $nfields;
|
|
}
|
|
|
|
foreach my $fold (@fold) {
|
|
my @row = ();
|
|
for my $index ( 0 .. $nfields) {
|
|
my @items = ();
|
|
foreach my $res (@results) {
|
|
if($index < scalar(@$res)) {
|
|
push @items, $res->[$index];
|
|
} else {
|
|
push @items, '';
|
|
}
|
|
}
|
|
|
|
push @row, eval "$fold";
|
|
}
|
|
|
|
push @results, \@row;
|
|
}
|
|
|
|
unshift @results, \@heading if @heading;
|
|
|
|
my @cols = (0) x $columns;
|
|
|
|
foreach my $result (@results) {
|
|
next unless $result;
|
|
my @items = @$result;
|
|
for(my $col = 0; $col != @items; ++$col) {
|
|
my $len = length $items[$col];
|
|
$cols[$col] = $len if $len > $cols[$col];
|
|
}
|
|
}
|
|
|
|
while(@results) {
|
|
my $res = shift @results;
|
|
my $col = 0;
|
|
foreach my $field (@$res) {
|
|
print $field;
|
|
my $whitespace = ' ' x (2 + $cols[$col] - (length $field));
|
|
print $whitespace;
|
|
++$col;
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
sub evaluate_expression
|
|
{
|
|
my ($unit,$expression) = @_;
|
|
|
|
my @attacks = ();
|
|
my @melee = ();
|
|
my @ranged = ();
|
|
|
|
my ($attack_name,$attack_damage,$attack_strikes,$attack_type,$attack_range,$attack_special) = ('',0,0,'','','');
|
|
my ($melee_name,$melee_damage,$melee_strikes,$melee_type,$melee_special) = ('',0,0,'','','');
|
|
my ($ranged_name,$ranged_damage,$ranged_strikes,$ranged_type,$ranged_special) = ('',0,0,'','');
|
|
|
|
foreach my $attack (@{$unit->{'children'}}) {
|
|
next unless $attack->{'name'} eq 'attack';
|
|
my %attr = %{$attack->{'attr'}};
|
|
push @attacks, \%attr;
|
|
|
|
my $power = $attr{'damage'}*$attr{'number'};
|
|
|
|
if($attr{'range'} eq 'short') {
|
|
if($power > $melee_damage*$melee_strikes) {
|
|
$melee_name = $attr{'name'};
|
|
$melee_damage = $attr{'damage'};
|
|
$melee_strikes = $attr{'number'};
|
|
$melee_type = $attr{'type'};
|
|
$melee_special = $attr{'special'};
|
|
}
|
|
|
|
push @melee, \%attr;
|
|
} else {
|
|
if($power > $ranged_damage*$ranged_strikes) {
|
|
$ranged_name = $attr{'name'};
|
|
$ranged_damage = $attr{'damage'};
|
|
$ranged_strikes = $attr{'number'};
|
|
$ranged_type = $attr{'type'};
|
|
$ranged_special = $attr{'special'};
|
|
}
|
|
push @ranged, \%attr;
|
|
}
|
|
|
|
if($power > $attack_damage*$attack_strikes) {
|
|
$attack_name = $attr{'name'};
|
|
$attack_damage = $attr{'damage'};
|
|
$attack_strikes = $attr{'number'};
|
|
$attack_type = $attr{'type'};
|
|
$attack_range = $attr{'range'};
|
|
$attack_special = $attr{'special'};
|
|
}
|
|
}
|
|
|
|
my ($secondary_name,$secondary_damage,$secondary_strikes,$secondary_type,$secondary_special) =
|
|
($melee_name,$melee_damage,$melee_strikes,$melee_type,$melee_special);
|
|
|
|
|
|
($secondary_name,$secondary_damage,$secondary_strikes,$secondary_type,$secondary_special) =
|
|
($ranged_name,$ranged_damage,$ranged_strikes,$ranged_type,$ranged_special)
|
|
if $attack_range eq 'short';
|
|
|
|
my $script = '{';
|
|
|
|
my %attr = %{$unit->{'attr'}};
|
|
while(my ($key,$value) = each(%attr)) {
|
|
$value =~ s/[^\s\w\.\,\-\:\;]//g;
|
|
$$key = $value;
|
|
}
|
|
|
|
foreach my $where (@where) {
|
|
$script .= "$where;";
|
|
}
|
|
|
|
$script .= "\[$expression\]\}";
|
|
|
|
my $result = eval($script);
|
|
while(my ($key,$value) = each(%attr)) {
|
|
$$key = '';
|
|
}
|
|
|
|
return $result;
|
|
}
|
|
|
|
sub compare_values
|
|
{
|
|
my ($a,$b) = @_;
|
|
return $a <=> $b if $a =~ /^[-\d\.]+$/ and $b =~ /^[-\d\.]+$/;
|
|
return $a cmp $b;
|
|
}
|