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 parsefile;
sub parsefile_;
sub gettoken;
sub fetchtemplates (_);
sub fixstatenames (_);

sub usage {
  print STDERR <<USAGE;
$0                              Display boolean keys
$0 key1 [key2 [...]]            Display items grouped by key
$0 -h|-v|-V|--help|--version    Display usage

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
}

sub parsefile {
  my ($filename) = @_;
  my $fp;
  unless (open $fp, '<', $filename) {
    die "Couldn't open $filename for reading";
  }
  my $res = parsefile_ $fp, $filename;
  close $fp;
  $res;
}

sub parsefile_ {
  my ($fp, $filename) = @_;
  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'\n";
  }
  local $/ = ']';
  my $firsttok = gettoken $fp, 1;
  if ($firsttok->[0] ne 'OBJECT') {
    print STDERR "Expected first token to be an OBJECT-token, got $firsttok->[0]\n";
  }
  if (!defined $firsttok->[1]) {
    print STDERR "In OBJECT-token, 1st arg is undef\n";
    return;
  }
  my $objecttype = $firsttok->[1];
  my $objects = [];
  my $objectsbyid = {};
  my $object = {};
  my $res = {object => $objecttype, objects => $objects, objectsbyid => $objectsbyid};
  my $pushobject = sub {
    push @$objects, $object if keys %$object;
    $objectsbyid->{$object->{id}} = $object if exists $object->{id};
    $object = {};
  };
  my $token;
  while ($token = gettoken $fp and keys %$token) {
    last unless keys %$token;
    next unless defined $token->{key};
    if ($token->{key} eq $objecttype) {
      $pushobject->();
      $object->{'id'} = $token->{value};
    } else {
      $object->{$token->{key}} = $token->{value};
    }
  }
  $pushobject->();
  $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;
  my ($key, $value) = ($token);
  if ($token =~ /^(STATE_[^:]+:[^:]+|[^:]+)(?::(.*))/) {
    ($key, $value) = ($1, $2);
  }
  return [$key, $value] if $asserttoken;
  return {comment => $comment, key => $key, value => $value};
}

if (($ARGV[0] // ) =~ /^(-[hvV]|--help|--version)$/) {
  usage();
  exit;
}

my $type = 'INORGANIC';
my $templatetype = 'MATERIAL_TEMPLATE';
my $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";
}
my %templates = %{$templates->{objectsbyid}};

my @objects;
for my $filename (<inorganic_*.txt>) {
  my $parsed = parsefile $filename;
  if ($parsed->{object} ne $type) {
    die "Expected objects of type $type in $filename, got $parsed->{object}";
  }
  push @objects, @{$parsed->{objects}};
}
fetchtemplates for @objects;
sub fetchtemplates (_) {
  my ($obj) = @_;
  my $id = $obj->{id};
  return unless defined $obj->{$templateincludekey};
  my $templatename = $obj->{$templateincludekey};
  my $template = $templates{$templatename};
  unless (defined $template) {
    print STDERR "Object $id references a template called $templatename, but it doesn't exist!\n";
    return;
  }
  delete $obj->{$templateincludekey};
  for my $key (keys %$template) {
    $obj->{$key} //= $template->{$key};
  }
}
fixstatenames for @objects;
sub fixstatenames (_) {
  my ($obj) = @_;
  if (($obj->{IS_GEM} // ) =~ /^([^:]+):[^:]+:OVERWRITE_SOLID/) {
    my $name = $1;
    $obj->{'STATE_NAME_ADJ:ALL_SOLID'} = $name;
  }
  for my $key (keys %$obj) {
    next unless $key =~ /^STATE_([^:]+_[^:]+):(.*)/;
    my $states = $1;
    my $subkey = $2;
    my $value = $obj->{$key};
    while ($states =~ /([^_]+)/g) {
      $obj->{"STATE_${1}:$subkey"} = $value;
    }
  }
  for my $key (keys %$obj) {
    next unless $key =~ /^(STATE_[^:]+:)ALL_SOLID/;
    my $prefix = $1;
    my $value = $obj->{$key};
    $obj->{$prefix.'SOLID'} = $value;
    $obj->{$prefix.'SOLID_POWDER'} = $value;
  }
}

my %objectsbytype;
for my $obj (@objects) {
  my @keys = grep {/^IS_/ or !defined $obj->{$_}} keys %$obj;
  for my $key (@keys) {
    $objectsbytype{$key} //= [];
    push @{$objectsbytype{$key}}, $obj;
  }
}
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;
}
if (@ARGV == 0) {
  for my $key (sort {@{$objectsbytype{$b}}-@{$objectsbytype{$a}}} keys %objectsbytype) {
    print tabstops(sprintf "%-30s %3d\n", $key, scalar @{$objectsbytype{$key}});
  }
} else {
  for my $key (@ARGV) {
    print "$key\n";
    my @rows;
    for my $obj (@{$objectsbytype{$key}}) {
      my @row = ($obj->{'STATE_NAME:SOLID'} // $obj->{'id'});
      for (qw(MATERIAL_VALUE MOLAR_MASS)) {
        push @row, $obj->{$_} // 0;
      }
      push @rows, \@row;
    }
    for my $row (sort {$a->[0] cmp $b->[0]} @rows) {
      print tabstops(sprintf "  %-26s %6d %10d\n", @$row);
    }
  }
}