User:Mortal

Novice Dwarffortressdwarf

rawparse.pl

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;
}