v50 Steam/Premium information for editors
- v50 information can now be added to pages in the main namespace. v0.47 information can still be found in the DF2014 namespace. See here for more details on the new versioning policy.
- Use this page to report any issues related to the migration.
This notice may be cached—the current version can be found here.
Difference between revisions of "User:Mortal"
Jump to navigation
Jump to search
(rawparse: Added usage info, and specifying keys on the command line) |
(Update script to newest version) |
||
Line 9: | Line 9: | ||
use strict; | use strict; | ||
+ | sub usage; | ||
+ | sub parsefiles; | ||
sub parsefile; | sub parsefile; | ||
− | |||
sub gettoken; | sub gettoken; | ||
− | sub | + | sub tabstops; |
− | sub | + | sub find_object; |
+ | sub find_by_key; | ||
sub usage { | sub usage { | ||
print STDERR <<USAGE; | print STDERR <<USAGE; | ||
− | $0 | + | $0 List boolean keys and number of objects |
− | $0 | + | $0 --all List all keys |
− | $0 -h|-v|-V|--help|--version Display | + | $0 -h|-v|-V|--help|--version This usage info |
+ | $0 sandy clay loam Display info about a single object | ||
+ | $0 'nickel silver' 'rose gold' Display info about several objects | ||
+ | $0 ITEMS_AMMO List objects by key | ||
rawparse.pl written by Mathias Rav, October 2010 | rawparse.pl written by Mathias Rav, October 2010 | ||
Line 25: | Line 30: | ||
Run the script from the df/raw/objects/ directory | Run the script from the df/raw/objects/ directory | ||
USAGE | USAGE | ||
+ | } | ||
+ | |||
+ | { | ||
+ | package Object; | ||
+ | sub new { | ||
+ | my ($class, $type, $id, @tokens) = @_; | ||
+ | my $self = bless {type => $type, id => $id, tokens => \@tokens}, $class; | ||
+ | $self->fetchtemplates(); | ||
+ | $self->fixstatenames(); | ||
+ | return $self; | ||
+ | } | ||
+ | sub matches { | ||
+ | my ($token, $prefix) = @_; | ||
+ | return 1 if $token eq $prefix; | ||
+ | return substr($token, length($prefix)+1) if $prefix.':' eq substr($token, 0, length($prefix)+1); | ||
+ | undef; | ||
+ | } | ||
+ | sub get { | ||
+ | my ($self, $prefix) = @_; | ||
+ | my @res; | ||
+ | for my $token (@{$self->{tokens}}) { | ||
+ | my $match = Object::matches($token, $prefix); | ||
+ | push @res, $match if defined $match; | ||
+ | return $res[0] if @res and !wantarray; | ||
+ | } | ||
+ | return @res; | ||
+ | } | ||
+ | sub remove { | ||
+ | my ($self, $prefix) = @_; | ||
+ | my @res; | ||
+ | $self->{tokens} = [grep { | ||
+ | my $match = Object::matches($_, $prefix); | ||
+ | if (defined $match) { | ||
+ | push @res, $match; | ||
+ | 0; | ||
+ | } else { | ||
+ | 1; | ||
+ | } | ||
+ | } @{$self->{tokens}}]; | ||
+ | return @res; | ||
+ | } | ||
+ | sub set { | ||
+ | my ($self, @vals) = @_; | ||
+ | unshift @{$self->{tokens}}, @vals; | ||
+ | } | ||
+ | sub setdefault { | ||
+ | my ($self, @vals) = @_; | ||
+ | push @{$self->{tokens}}, @vals; | ||
+ | } | ||
+ | sub fetchtemplates { | ||
+ | my ($self) = @_; | ||
+ | my $id = $self->{id}; | ||
+ | my @templates = $self->remove($main::templateincludekey); | ||
+ | $self->applytemplate($_) for @templates; | ||
+ | } | ||
+ | sub applytemplate { | ||
+ | my ($self, $templatename) = @_; | ||
+ | my $template = $main::templates{$templatename}; | ||
+ | unless (defined $template) { | ||
+ | printf STDERR "Object %s references a template called $templatename, but it doesn't exist!\n", $self->id(); | ||
+ | return; | ||
+ | } | ||
+ | $self->setdefault(@{$template->{tokens}}); | ||
+ | } | ||
+ | sub fixstatenames { | ||
+ | my ($self) = @_; | ||
+ | if ($self->get('IS_GEM') =~ /^([^:]+):[^:]+:OVERWRITE_SOLID/) { | ||
+ | my $name = $1; | ||
+ | $self->set("STATE_NAME_ADJ:ALL_SOLID:$name"); | ||
+ | } | ||
+ | my @tokens = @{$self->{tokens}}; | ||
+ | for my $token (reverse @tokens) { # reverse so high priority tokens are set last | ||
+ | next unless $token =~ /^STATE_([^:]+_[^:]+):(.*)/; | ||
+ | my $states = $1; | ||
+ | my $subkey = $2; | ||
+ | while ($states =~ /([^_]+)/g) { | ||
+ | $self->set("STATE_${1}:$subkey"); | ||
+ | } | ||
+ | } | ||
+ | @tokens = @{$self->{tokens}}; | ||
+ | for my $token (reverse @tokens) { | ||
+ | next unless $token =~ /^(STATE_[^:]+:)ALL_SOLID(:.*)/; | ||
+ | my $prefix = $1; | ||
+ | my $suffix = $2; | ||
+ | $self->set($prefix.'SOLID'.$suffix); | ||
+ | $self->set($prefix.'SOLID_POWDER'.$suffix); | ||
+ | } | ||
+ | } | ||
+ | sub id { | ||
+ | my ($self) = @_; | ||
+ | return $self->{id}; | ||
+ | } | ||
+ | sub name { | ||
+ | my ($self) = @_; | ||
+ | return scalar($self->get('STATE_NAME:SOLID')) // scalar($self->get('STATE_ADJ:SOLID')); | ||
+ | } | ||
+ | sub type { | ||
+ | my ($self) = @_; | ||
+ | map {if (/^IS_([^:]+)/) {lc $1;} else {();}} @{$self->{tokens}}; | ||
+ | } | ||
+ | sub layer { | ||
+ | my ($self) = @_; | ||
+ | my %layers = ( | ||
+ | SOIL => 'soil layer', | ||
+ | SOIL_OCEAN => 'pelagic sediment layer', | ||
+ | SEDIMENTARY => 'sedimentary layer', | ||
+ | METAMORPHIC => 'metamorphic layer', | ||
+ | IGNEOUS_EXTRUSIVE => 'igneous extrusive layer', | ||
+ | SEDIMENTARY_OCEAN_SHALLOW => 'covers shallow ocean floors', | ||
+ | IGNEOUS_INTRUSIVE => 'igneous intrusive layer', | ||
+ | SEDIMENTARY_OCEAN_DEEP => 'covers deep ocean floors', | ||
+ | LAVA => 'covers magma pools', | ||
+ | DEEP_SURFACE => 'covers the deep surface', | ||
+ | AQUIFER => 'can contain aquifer', | ||
+ | ); | ||
+ | map {$layers{$_}} grep {$self->get($_)} keys %layers; | ||
+ | } | ||
+ | sub magmastatus { | ||
+ | my ($self) = @_; | ||
+ | if ($self->get('BOILING_POINT') <= 12000) { | ||
+ | 'boils in magma'; | ||
+ | } elsif ($self->get('MELTING_POINT') <= 12000) { | ||
+ | 'melts in magma'; | ||
+ | } else { | ||
+ | 'magma-safe'; | ||
+ | } | ||
+ | } | ||
+ | sub print { | ||
+ | my ($self) = @_; | ||
+ | $self->print_header; | ||
+ | $self->print_uses; | ||
+ | $self->print_location; | ||
+ | #$self->print_raw; | ||
+ | } | ||
+ | sub print_header { | ||
+ | my ($self) = @_; | ||
+ | $self->print_title; | ||
+ | $self->print_value; | ||
+ | } | ||
+ | sub print_title { | ||
+ | my ($self) = @_; | ||
+ | my $type = join '', map {", $_"} $self->type; | ||
+ | my $layer = join '', map {", $_"} $self->layer; | ||
+ | print ucfirst($self->name()), $type, $layer, ', ', $self->magmastatus, "\n"; | ||
+ | } | ||
+ | sub print_location { | ||
+ | my ($self) = @_; | ||
+ | my $header = "== Location ==\n"; | ||
+ | for my $location ($self->get('ENVIRONMENT')) { | ||
+ | my ($layer, $occurrence, $value) = split ':', $location; | ||
+ | my %occurrences = (CLUSTER_SMALL => 'small clusters'); | ||
+ | if (defined $occurrences{$occurrence}) { | ||
+ | $occurrence = $occurrences{$occurrence}; | ||
+ | } else { | ||
+ | $occurrence = lc $occurrence; | ||
+ | $occurrence =~ s/_/ /g; | ||
+ | } | ||
+ | $layer = lc $layer; | ||
+ | $layer =~ s/_/ /g; | ||
+ | printf "%sFound in %s layers as %s\n", $header, lc($layer), $occurrence; | ||
+ | $header = '' | ||
+ | } | ||
+ | for my $location ($self->get('ENVIRONMENT_SPEC')) { | ||
+ | my ($layer, $occurrence, $value) = split ':', $location; | ||
+ | my %occurrences = (CLUSTER_SMALL => 'small clusters'); | ||
+ | if (defined $occurrences{$occurrence}) { | ||
+ | $occurrence = $occurrences{$occurrence}; | ||
+ | } else { | ||
+ | $occurrence = lc $occurrence; | ||
+ | $occurrence =~ s/_/ /g; | ||
+ | } | ||
+ | printf "%sFound within %s as %s\n", $header, $main::objectsbyid{$layer}->name, $occurrence; | ||
+ | $header = ''; | ||
+ | } | ||
+ | } | ||
+ | sub print_value { | ||
+ | my ($self) = @_; | ||
+ | printf "Material value %d\n", $self->get('MATERIAL_VALUE'); | ||
+ | } | ||
+ | sub print_uses { | ||
+ | my ($self) = @_; | ||
+ | print "== Uses ==\n"; | ||
+ | $self->print_ores; | ||
+ | $self->print_crafts; | ||
+ | $self->print_reactions; | ||
+ | } | ||
+ | sub print_ores { | ||
+ | my ($self) = @_; | ||
+ | for my $ore ($self->get('METAL_ORE')) { | ||
+ | my ($metalid, $chance) = (split(':', $ore, 2)); | ||
+ | my $metal = $main::objectsbyid{$metalid}; | ||
+ | my $metalname = defined($metal) ? $metal->name() : $metalid; | ||
+ | printf "* Ore of %s (%d%%)\n", $metalname, $chance; | ||
+ | } | ||
+ | } | ||
+ | sub print_crafts { | ||
+ | my ($self) = @_; | ||
+ | if ($self->get('IS_STONE')) { | ||
+ | print "* Masonry\n* Stone crafting\n* Construction\n"; | ||
+ | } | ||
+ | if ($self->get('IS_METAL')) { | ||
+ | print "* Metal crafting\n* Construction\n"; | ||
+ | } | ||
+ | if ($self->get('IS_GEM')) { | ||
+ | print "* Gemcrafting\n* Encrusting\n"; | ||
+ | } | ||
+ | } | ||
+ | sub print_reactions { | ||
+ | my ($self) = @_; | ||
+ | for my $reaction (@{$main::reactions->{objects}}) { | ||
+ | my $match = 0; | ||
+ | for my $reagent ($reaction->get('REAGENT')) { | ||
+ | my ($name, $quantity, $itemtoken, $itemsubtype, $materialtoken, $materialsubtype) = split ':', $reagent; | ||
+ | my @values = map {s/:.*//; $_} $self->get($itemtoken); | ||
+ | #print "My values of $itemtoken are '@values', id $self->{id}, type $self->{type}, expecting value $itemsubtype"; | ||
+ | #if (defined $materialtoken) {print ", material $materialtoken of type $materialsubtype";} | ||
+ | #print "\n"; | ||
+ | if ( | ||
+ | # does the reaction require anything? | ||
+ | ($itemsubtype ne 'NONE' and $itemsubtype ne 'NO_SUBTYPE' or defined $materialtoken and $materialtoken ne 'NONE' or defined $materialsubtype and $materialsubtype ne 'NO_SUBTYPE' and $materialsubtype ne 'NONE') and ( | ||
+ | |||
+ | # it requires something. do we match the item subtype? | ||
+ | (@values ~~ $itemsubtype) | ||
+ | |||
+ | # if not, do we match the material? | ||
+ | or defined($materialtoken) and ($materialtoken eq $self->{type} or $self->get("IS_$materialtoken")) and ($materialsubtype eq 'NO_SUBTYPE' or $materialsubtype eq $self->{id}))) { | ||
+ | |||
+ | # we're a match! | ||
+ | $match = 1; | ||
+ | } | ||
+ | } | ||
+ | if ($match) { | ||
+ | printf "* %s\n", ucfirst scalar($reaction->get('NAME')); | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | sub print_raw { | ||
+ | my ($self) = @_; | ||
+ | printf "[%s]\n", $_ for @{$self->{tokens}}; | ||
+ | } | ||
+ | } | ||
+ | |||
+ | sub parsefiles { | ||
+ | my ($expecttype, @filenames) = @_; | ||
+ | my @objects; | ||
+ | my %objectsbyid; | ||
+ | for my $filename (@filenames) { | ||
+ | my $parsed = parsefile($filename); | ||
+ | if ($parsed->{object} ne $expecttype) { | ||
+ | die "Expected objects of type $expecttype in $filename, got $parsed->{object}"; | ||
+ | } | ||
+ | push @objects, @{$parsed->{objects}}; | ||
+ | %objectsbyid = (%objectsbyid, %{$parsed->{objectsbyid}}); | ||
+ | } | ||
+ | return {objects => \@objects, objectsbyid => \%objectsbyid}; | ||
} | } | ||
Line 31: | Line 291: | ||
my $fp; | my $fp; | ||
unless (open $fp, '<', $filename) { | unless (open $fp, '<', $filename) { | ||
− | + | print STDERR "Couldn't open $filename for reading. Are you in the right directory?"; | |
+ | exit 1; | ||
} | } | ||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
my $expectfilename = $filename; | my $expectfilename = $filename; | ||
$expectfilename =~ s/^.*\/|\.txt$//g; | $expectfilename =~ s/^.*\/|\.txt$//g; | ||
Line 45: | Line 299: | ||
$gotfilename =~ s/\r?\n?$//s; | $gotfilename =~ s/\r?\n?$//s; | ||
if ($expectfilename ne $gotfilename) { | if ($expectfilename ne $gotfilename) { | ||
− | print STDERR "Expected filename '$expectfilename' in $filename, got '$gotfilename'\n"; | + | print STDERR "Expected filename '$expectfilename' in $filename, got '$gotfilename' (ignoring)\n"; |
} | } | ||
local $/ = ']'; | local $/ = ']'; | ||
my $firsttok = gettoken $fp, 1; | my $firsttok = gettoken $fp, 1; | ||
− | + | unless ($firsttok =~ /^OBJECT:(.*)/) { | |
print STDERR "Expected first token to be an OBJECT-token, got $firsttok->[0]\n"; | print STDERR "Expected first token to be an OBJECT-token, got $firsttok->[0]\n"; | ||
} | } | ||
− | + | my $objecttype = $1; | |
− | |||
− | |||
− | |||
− | my $objecttype = $ | ||
my $objects = []; | my $objects = []; | ||
my $objectsbyid = {}; | my $objectsbyid = {}; | ||
− | |||
my $res = {object => $objecttype, objects => $objects, objectsbyid => $objectsbyid}; | my $res = {object => $objecttype, objects => $objects, objectsbyid => $objectsbyid}; | ||
+ | my $objectid; | ||
+ | my @object; | ||
my $pushobject = sub { | my $pushobject = sub { | ||
− | push @$objects, | + | if (defined $objectid) { |
− | + | my $object = Object->new($objecttype, $objectid, @object); | |
− | $ | + | push @$objects, $object; |
+ | $objectsbyid->{$object->id()} = $object; | ||
+ | } | ||
+ | @object = (); | ||
+ | $objectid = undef; | ||
}; | }; | ||
my $token; | my $token; | ||
while ($token = gettoken $fp and keys %$token) { | while ($token = gettoken $fp and keys %$token) { | ||
last unless keys %$token; | last unless keys %$token; | ||
− | next unless defined $token->{ | + | next unless defined $token->{token}; |
− | + | $token = $token->{token}; | |
+ | if (substr($token, 0, length($objecttype)) eq $objecttype) { | ||
$pushobject->(); | $pushobject->(); | ||
− | $ | + | $token =~ s/[^:]*://; |
+ | $objectid = $token; | ||
} else { | } else { | ||
− | + | push @object, $token; | |
} | } | ||
} | } | ||
$pushobject->(); | $pushobject->(); | ||
+ | close $fp; | ||
$res; | $res; | ||
} | } | ||
Line 102: | Line 360: | ||
$comment =~ s/^\s+|\s+$//g; | $comment =~ s/^\s+|\s+$//g; | ||
$comment = undef unless length $comment; | $comment = undef unless length $comment; | ||
− | + | return $token if $asserttoken; | |
− | + | return {comment => $comment, token => $token}; | |
− | |||
− | |||
− | |||
− | return {comment => $comment, | ||
} | } | ||
Line 115: | Line 369: | ||
} | } | ||
− | + | # at the moment only inorganics are supported | |
− | + | our $type = 'INORGANIC'; | |
− | + | our $templatetype = 'MATERIAL_TEMPLATE'; | |
+ | our $templateincludekey = "USE_$templatetype"; | ||
my $templates = parsefile 'material_template_default.txt'; | my $templates = parsefile 'material_template_default.txt'; | ||
if ($templates->{object} ne $templatetype) { | if ($templates->{object} ne $templatetype) { | ||
die "Template file contains objects of type $templates->{object}, expected $templatetype"; | die "Template file contains objects of type $templates->{object}, expected $templatetype"; | ||
} | } | ||
− | + | our %templates = %{$templates->{objectsbyid}}; | |
− | + | my $parsed = parsefiles($type, <inorganic_*.txt>); | |
− | + | our @objects = @{$parsed->{objects}}; | |
− | + | our %objectsbyid = %{$parsed->{objectsbyid}}; | |
− | + | ||
− | + | our $reactions = parsefiles('REACTION', <reaction_*.txt>); | |
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
− | |||
sub tabstops { | sub tabstops { | ||
my ($line) = @_; | my ($line) = @_; | ||
Line 189: | Line 393: | ||
$line.$suffix; | $line.$suffix; | ||
} | } | ||
− | if ( | + | sub find_object { |
− | + | my ($name) = @_; | |
− | + | if (exists $objectsbyid{$name}) { | |
+ | $objectsbyid{$name}->print; | ||
+ | } elsif (exists $objectsbyid{uc $name}) { | ||
+ | $objectsbyid{uc $name}->print; | ||
+ | } else { | ||
+ | for my $obj (@objects) { | ||
+ | if (lc($obj->name) eq lc($name)) { | ||
+ | $obj->print; | ||
+ | return 1; | ||
+ | } | ||
+ | } | ||
+ | } | ||
+ | 0; | ||
+ | } | ||
+ | |||
+ | sub find_by_key { | ||
+ | my @keys = @_; | ||
+ | my %objectsbytype; | ||
+ | for my $obj (@objects) { | ||
+ | for my $key (@keys) { | ||
+ | my @vals = $obj->get($key); | ||
+ | next unless @vals; | ||
+ | $objectsbytype{$key} //= []; | ||
+ | push @{$objectsbytype{$key}}, $obj; | ||
+ | } | ||
} | } | ||
− | + | return 0 unless keys %objectsbytype; | |
− | for my $key ( | + | for my $key (keys %objectsbytype) { |
print "$key\n"; | print "$key\n"; | ||
my @rows; | my @rows; | ||
+ | my $boolean = 0; | ||
+ | my $numeric = 1; | ||
for my $obj (@{$objectsbytype{$key}}) { | for my $obj (@{$objectsbytype{$key}}) { | ||
− | my @row = ($obj-> | + | my @row = ($obj->name); |
for (qw(MATERIAL_VALUE MOLAR_MASS)) { | for (qw(MATERIAL_VALUE MOLAR_MASS)) { | ||
− | push @row, $obj-> | + | push @row, scalar($obj->get($_)) // 0; |
+ | } | ||
+ | my $val = $obj->get($key); | ||
+ | if (defined $val) { | ||
+ | push @row, $val; | ||
+ | $numeric = 0 if $numeric and $val =~ /\D/; | ||
+ | } else { | ||
+ | push @row, ''; | ||
+ | $boolean = 1; | ||
} | } | ||
push @rows, \@row; | push @rows, \@row; | ||
} | } | ||
− | + | if ($boolean) { | |
− | print tabstops(sprintf " %-26s %6d %10d\n", @$row); | + | @rows = sort {$a->[0] cmp $b->[0]} @rows; |
+ | } elsif ($numeric) { | ||
+ | @rows = sort {$a->[3] <=> $b->[3]} @rows; | ||
+ | } else { | ||
+ | @rows = sort {$a->[3] cmp $b->[3]} @rows; | ||
+ | } | ||
+ | for my $row (@rows) { | ||
+ | print tabstops(sprintf " %-26s %6d %10d %s\n", @$row); | ||
+ | } | ||
+ | } | ||
+ | 1; | ||
+ | } | ||
+ | if (@ARGV == 0) { | ||
+ | my %booleankeys; | ||
+ | for my $obj (@objects) { | ||
+ | my @keys = grep {/^IS_|^[^:]+$/} @{$obj->{tokens}}; | ||
+ | for my $key (@keys) { | ||
+ | $key =~ s/:.*//g; | ||
+ | $booleankeys{$key} //= 0; | ||
+ | ++$booleankeys{$key}; | ||
} | } | ||
} | } | ||
+ | for my $key (sort {$booleankeys{$b}-$booleankeys{$a}} keys %booleankeys) { | ||
+ | print tabstops(sprintf "%-30s %3d\n", $key, $booleankeys{$key}); | ||
+ | } | ||
+ | } elsif (@ARGV == 1 and $ARGV[0] eq '--all') { | ||
+ | my %keys = (); | ||
+ | for my $obj (@objects) { | ||
+ | for my $token (@{$obj->{tokens}}) { | ||
+ | while ($token =~ /:/g) { | ||
+ | my $key = substr($token, 0, $-[0]); | ||
+ | $keys{$key} //= 0; | ||
+ | ++$keys{$key}; | ||
+ | } | ||
+ | $keys{$token} //= 0; | ||
+ | ++$keys{$token}; | ||
+ | } | ||
+ | } | ||
+ | my @keys = grep {/:[^:]*[^:\d][^:]*$/ and ($keys{$_} > 1 or !/:/)} keys %keys; | ||
+ | { | ||
+ | local $, = ', '; | ||
+ | local $\ = "\n"; | ||
+ | print map {"$_ ($keys{$_})"} sort {$keys{$b}-$keys{$a}} @keys; | ||
+ | } | ||
+ | } else { | ||
+ | exit if find_object "@ARGV"; | ||
+ | exit if map {find_object($_) ? (1) : ()} @ARGV; | ||
+ | exit if find_by_key @ARGV; | ||
+ | print STDERR "I couldn't understand that.\n"; | ||
+ | usage; | ||
+ | exit 1; | ||
} | } |
Latest revision as of 19:23, 23 October 2010
Novice Dwarffortressdwarf
rawparse.pl[edit]
Put it in your raw/objects folder! Output as of 0.31.16
#!/usr/bin/perl use warnings; use strict; sub usage; sub parsefiles; sub parsefile; sub gettoken; sub tabstops; sub find_object; sub find_by_key; sub usage { print STDERR <<USAGE; $0 List boolean keys and number of objects $0 --all List all keys $0 -h|-v|-V|--help|--version This usage info $0 sandy clay loam Display info about a single object $0 'nickel silver' 'rose gold' Display info about several objects $0 ITEMS_AMMO List objects by key rawparse.pl written by Mathias Rav, October 2010 For Dwarf Fortress 0.31.16 and compatible raw formats Run the script from the df/raw/objects/ directory USAGE } { package Object; sub new { my ($class, $type, $id, @tokens) = @_; my $self = bless {type => $type, id => $id, tokens => \@tokens}, $class; $self->fetchtemplates(); $self->fixstatenames(); return $self; } sub matches { my ($token, $prefix) = @_; return 1 if $token eq $prefix; return substr($token, length($prefix)+1) if $prefix.':' eq substr($token, 0, length($prefix)+1); undef; } sub get { my ($self, $prefix) = @_; my @res; for my $token (@{$self->{tokens}}) { my $match = Object::matches($token, $prefix); push @res, $match if defined $match; return $res[0] if @res and !wantarray; } return @res; } sub remove { my ($self, $prefix) = @_; my @res; $self->{tokens} = [grep { my $match = Object::matches($_, $prefix); if (defined $match) { push @res, $match; 0; } else { 1; } } @{$self->{tokens}}]; return @res; } sub set { my ($self, @vals) = @_; unshift @{$self->{tokens}}, @vals; } sub setdefault { my ($self, @vals) = @_; push @{$self->{tokens}}, @vals; } sub fetchtemplates { my ($self) = @_; my $id = $self->{id}; my @templates = $self->remove($main::templateincludekey); $self->applytemplate($_) for @templates; } sub applytemplate { my ($self, $templatename) = @_; my $template = $main::templates{$templatename}; unless (defined $template) { printf STDERR "Object %s references a template called $templatename, but it doesn't exist!\n", $self->id(); return; } $self->setdefault(@{$template->{tokens}}); } sub fixstatenames { my ($self) = @_; if ($self->get('IS_GEM') =~ /^([^:]+):[^:]+:OVERWRITE_SOLID/) { my $name = $1; $self->set("STATE_NAME_ADJ:ALL_SOLID:$name"); } my @tokens = @{$self->{tokens}}; for my $token (reverse @tokens) { # reverse so high priority tokens are set last next unless $token =~ /^STATE_([^:]+_[^:]+):(.*)/; my $states = $1; my $subkey = $2; while ($states =~ /([^_]+)/g) { $self->set("STATE_${1}:$subkey"); } } @tokens = @{$self->{tokens}}; for my $token (reverse @tokens) { next unless $token =~ /^(STATE_[^:]+:)ALL_SOLID(:.*)/; my $prefix = $1; my $suffix = $2; $self->set($prefix.'SOLID'.$suffix); $self->set($prefix.'SOLID_POWDER'.$suffix); } } sub id { my ($self) = @_; return $self->{id}; } sub name { my ($self) = @_; return scalar($self->get('STATE_NAME:SOLID')) // scalar($self->get('STATE_ADJ:SOLID')); } sub type { my ($self) = @_; map {if (/^IS_([^:]+)/) {lc $1;} else {();}} @{$self->{tokens}}; } sub layer { my ($self) = @_; my %layers = ( SOIL => 'soil layer', SOIL_OCEAN => 'pelagic sediment layer', SEDIMENTARY => 'sedimentary layer', METAMORPHIC => 'metamorphic layer', IGNEOUS_EXTRUSIVE => 'igneous extrusive layer', SEDIMENTARY_OCEAN_SHALLOW => 'covers shallow ocean floors', IGNEOUS_INTRUSIVE => 'igneous intrusive layer', SEDIMENTARY_OCEAN_DEEP => 'covers deep ocean floors', LAVA => 'covers magma pools', DEEP_SURFACE => 'covers the deep surface', AQUIFER => 'can contain aquifer', ); map {$layers{$_}} grep {$self->get($_)} keys %layers; } sub magmastatus { my ($self) = @_; if ($self->get('BOILING_POINT') <= 12000) { 'boils in magma'; } elsif ($self->get('MELTING_POINT') <= 12000) { 'melts in magma'; } else { 'magma-safe'; } } sub print { my ($self) = @_; $self->print_header; $self->print_uses; $self->print_location; #$self->print_raw; } sub print_header { my ($self) = @_; $self->print_title; $self->print_value; } sub print_title { my ($self) = @_; my $type = join , map {", $_"} $self->type; my $layer = join , map {", $_"} $self->layer; print ucfirst($self->name()), $type, $layer, ', ', $self->magmastatus, "\n"; } sub print_location { my ($self) = @_; my $header = "== Location ==\n"; for my $location ($self->get('ENVIRONMENT')) { my ($layer, $occurrence, $value) = split ':', $location; my %occurrences = (CLUSTER_SMALL => 'small clusters'); if (defined $occurrences{$occurrence}) { $occurrence = $occurrences{$occurrence}; } else { $occurrence = lc $occurrence; $occurrence =~ s/_/ /g; } $layer = lc $layer; $layer =~ s/_/ /g; printf "%sFound in %s layers as %s\n", $header, lc($layer), $occurrence; $header = } for my $location ($self->get('ENVIRONMENT_SPEC')) { my ($layer, $occurrence, $value) = split ':', $location; my %occurrences = (CLUSTER_SMALL => 'small clusters'); if (defined $occurrences{$occurrence}) { $occurrence = $occurrences{$occurrence}; } else { $occurrence = lc $occurrence; $occurrence =~ s/_/ /g; } printf "%sFound within %s as %s\n", $header, $main::objectsbyid{$layer}->name, $occurrence; $header = ; } } sub print_value { my ($self) = @_; printf "Material value %d\n", $self->get('MATERIAL_VALUE'); } sub print_uses { my ($self) = @_; print "== Uses ==\n"; $self->print_ores; $self->print_crafts; $self->print_reactions; } sub print_ores { my ($self) = @_; for my $ore ($self->get('METAL_ORE')) { my ($metalid, $chance) = (split(':', $ore, 2)); my $metal = $main::objectsbyid{$metalid}; my $metalname = defined($metal) ? $metal->name() : $metalid; printf "* Ore of %s (%d%%)\n", $metalname, $chance; } } sub print_crafts { my ($self) = @_; if ($self->get('IS_STONE')) { print "* Masonry\n* Stone crafting\n* Construction\n"; } if ($self->get('IS_METAL')) { print "* Metal crafting\n* Construction\n"; } if ($self->get('IS_GEM')) { print "* Gemcrafting\n* Encrusting\n"; } } sub print_reactions { my ($self) = @_; for my $reaction (@{$main::reactions->{objects}}) { my $match = 0; for my $reagent ($reaction->get('REAGENT')) { my ($name, $quantity, $itemtoken, $itemsubtype, $materialtoken, $materialsubtype) = split ':', $reagent; my @values = map {s/:.*//; $_} $self->get($itemtoken); #print "My values of $itemtoken are '@values', id $self->{id}, type $self->{type}, expecting value $itemsubtype"; #if (defined $materialtoken) {print ", material $materialtoken of type $materialsubtype";} #print "\n"; if ( # does the reaction require anything? ($itemsubtype ne 'NONE' and $itemsubtype ne 'NO_SUBTYPE' or defined $materialtoken and $materialtoken ne 'NONE' or defined $materialsubtype and $materialsubtype ne 'NO_SUBTYPE' and $materialsubtype ne 'NONE') and ( # it requires something. do we match the item subtype? (@values ~~ $itemsubtype) # if not, do we match the material? or defined($materialtoken) and ($materialtoken eq $self->{type} or $self->get("IS_$materialtoken")) and ($materialsubtype eq 'NO_SUBTYPE' or $materialsubtype eq $self->{id}))) { # we're a match! $match = 1; } } if ($match) { printf "* %s\n", ucfirst scalar($reaction->get('NAME')); } } } sub print_raw { my ($self) = @_; printf "[%s]\n", $_ for @{$self->{tokens}}; } } sub parsefiles { my ($expecttype, @filenames) = @_; my @objects; my %objectsbyid; for my $filename (@filenames) { my $parsed = parsefile($filename); if ($parsed->{object} ne $expecttype) { die "Expected objects of type $expecttype in $filename, got $parsed->{object}"; } push @objects, @{$parsed->{objects}}; %objectsbyid = (%objectsbyid, %{$parsed->{objectsbyid}}); } return {objects => \@objects, objectsbyid => \%objectsbyid}; } sub parsefile { my ($filename) = @_; my $fp; unless (open $fp, '<', $filename) { print STDERR "Couldn't open $filename for reading. Are you in the right directory?"; exit 1; } my $expectfilename = $filename; $expectfilename =~ s/^.*\/|\.txt$//g; my $gotfilename = <$fp>; $gotfilename =~ s/\r?\n?$//s; if ($expectfilename ne $gotfilename) { print STDERR "Expected filename '$expectfilename' in $filename, got '$gotfilename' (ignoring)\n"; } local $/ = ']'; my $firsttok = gettoken $fp, 1; unless ($firsttok =~ /^OBJECT:(.*)/) { print STDERR "Expected first token to be an OBJECT-token, got $firsttok->[0]\n"; } my $objecttype = $1; my $objects = []; my $objectsbyid = {}; my $res = {object => $objecttype, objects => $objects, objectsbyid => $objectsbyid}; my $objectid; my @object; my $pushobject = sub { if (defined $objectid) { my $object = Object->new($objecttype, $objectid, @object); push @$objects, $object; $objectsbyid->{$object->id()} = $object; } @object = (); $objectid = undef; }; my $token; while ($token = gettoken $fp and keys %$token) { last unless keys %$token; next unless defined $token->{token}; $token = $token->{token}; if (substr($token, 0, length($objecttype)) eq $objecttype) { $pushobject->(); $token =~ s/[^:]*://; $objectid = $token; } else { push @object, $token; } } $pushobject->(); close $fp; $res; } sub gettoken { my ($fp, $asserttoken) = @_; $_ = <$fp>; my $input = $_; if (!defined) { if ($asserttoken) { die "Expected a token, but got EOF"; } return {}; } unless (/([^[]*)\[(.*)\]/) { if ($asserttoken) { die "Expected a token, but got none"; } my $comment = $_; $comment =~ s/^\s+|\s+$//g; return {comment => $comment}; } my ($comment, $token) = ($1, $2); $comment =~ s/^\s+|\s+$//g; $comment = undef unless length $comment; return $token if $asserttoken; return {comment => $comment, token => $token}; } if (($ARGV[0] // ) =~ /^(-[hvV]|--help|--version)$/) { usage(); exit; } # at the moment only inorganics are supported our $type = 'INORGANIC'; our $templatetype = 'MATERIAL_TEMPLATE'; our $templateincludekey = "USE_$templatetype"; my $templates = parsefile 'material_template_default.txt'; if ($templates->{object} ne $templatetype) { die "Template file contains objects of type $templates->{object}, expected $templatetype"; } our %templates = %{$templates->{objectsbyid}}; my $parsed = parsefiles($type, <inorganic_*.txt>); our @objects = @{$parsed->{objects}}; our %objectsbyid = %{$parsed->{objectsbyid}}; our $reactions = parsefiles('REACTION', <reaction_*.txt>); sub tabstops { my ($line) = @_; my $suffix; ($line, $suffix) = $line =~ /^(.*?)([\r\n]*)$/s; my $len = length($line)%8; $line =~ s/ {2,8}(?=(.{8})*.{$len}$)/\t/g; $line.$suffix; } sub find_object { my ($name) = @_; if (exists $objectsbyid{$name}) { $objectsbyid{$name}->print; } elsif (exists $objectsbyid{uc $name}) { $objectsbyid{uc $name}->print; } else { for my $obj (@objects) { if (lc($obj->name) eq lc($name)) { $obj->print; return 1; } } } 0; } sub find_by_key { my @keys = @_; my %objectsbytype; for my $obj (@objects) { for my $key (@keys) { my @vals = $obj->get($key); next unless @vals; $objectsbytype{$key} //= []; push @{$objectsbytype{$key}}, $obj; } } return 0 unless keys %objectsbytype; for my $key (keys %objectsbytype) { print "$key\n"; my @rows; my $boolean = 0; my $numeric = 1; for my $obj (@{$objectsbytype{$key}}) { my @row = ($obj->name); for (qw(MATERIAL_VALUE MOLAR_MASS)) { push @row, scalar($obj->get($_)) // 0; } my $val = $obj->get($key); if (defined $val) { push @row, $val; $numeric = 0 if $numeric and $val =~ /\D/; } else { push @row, ; $boolean = 1; } push @rows, \@row; } if ($boolean) { @rows = sort {$a->[0] cmp $b->[0]} @rows; } elsif ($numeric) { @rows = sort {$a->[3] <=> $b->[3]} @rows; } else { @rows = sort {$a->[3] cmp $b->[3]} @rows; } for my $row (@rows) { print tabstops(sprintf " %-26s %6d %10d %s\n", @$row); } } 1; } if (@ARGV == 0) { my %booleankeys; for my $obj (@objects) { my @keys = grep {/^IS_|^[^:]+$/} @{$obj->{tokens}}; for my $key (@keys) { $key =~ s/:.*//g; $booleankeys{$key} //= 0; ++$booleankeys{$key}; } } for my $key (sort {$booleankeys{$b}-$booleankeys{$a}} keys %booleankeys) { print tabstops(sprintf "%-30s %3d\n", $key, $booleankeys{$key}); } } elsif (@ARGV == 1 and $ARGV[0] eq '--all') { my %keys = (); for my $obj (@objects) { for my $token (@{$obj->{tokens}}) { while ($token =~ /:/g) { my $key = substr($token, 0, $-[0]); $keys{$key} //= 0; ++$keys{$key}; } $keys{$token} //= 0; ++$keys{$token}; } } my @keys = grep {/:[^:]*[^:\d][^:]*$/ and ($keys{$_} > 1 or !/:/)} keys %keys; { local $, = ', '; local $\ = "\n"; print map {"$_ ($keys{$_})"} sort {$keys{$b}-$keys{$a}} @keys; } } else { exit if find_object "@ARGV"; exit if map {find_object($_) ? (1) : ()} @ARGV; exit if find_by_key @ARGV; print STDERR "I couldn't understand that.\n"; usage; exit 1; }