cata_edit.pl

#############################################################
#
# Скрипт модифицирует игровые файлы с целью уменьшить простои вроде
# установки каждой рамы по 2 часа и чтения одной книги весь день.
#
# Резервная копия оригинальных файлов сохраняется в data.bk в папке игры.
# Оригинальные файлы можно восстановить запустив скрипт с ключом --restore.
# Лог всех изменений сохраняется в cata_edit.log рядом со скриптом.
# Пример лога: https://pastebin.com/raw/CkSwDgnE
#
#
# В случае ошибки "Can't locate ХХХ/XXX.pm" установить зависимости:
#
# # curl -L https://cpanmin.us | perl - App::cpanminus
# # cpanm --notest XXX::XXX
#
#############################################################

use v5.20;
use autodie;
no warnings "experimental";

use File::Slurp qw/read_file write_file/;
use File::Find::Rule;
use File::Copy::Recursive qw/dircopy/;
use File::Path qw/remove_tree/;
use List::Util qw/min max/;
use List::MoreUtils qw/first_index first_value any/;
use JSON;

#------------------------------------------------------------

# Путь к игре где лежит папка data
our $game_path = "c:/Games/Cataclysm";

# Настройки
our %settings = (
   # Коэффициенты времени выполнения
   # 1 = 100%
   parts_install_time => 0.2, # Время установки деталей 0.2 = 20%
   parts_repair_time  => 0.2, # Ремонта
   parts_removal_time => 0.2, # Удаления

   craft_time         => 0.2, # Время крафта
   books_time         => 0.2, # Чтения

   # К указанной мутации добавляется эффект ускоренного сна
   sleep_acceliration => 1.0,            # 1.0 = энергия восстанавливается на 100% быстрее
   sleep_mutation_id  => "HEAVYSLEEPER", # Крепкий сон
);

#------------------------------------------------------------

sub report($;@) {
   my(@strings) = map { "$_\n" } @_;

   state $log;
   open $log, ">", "cata_edit.log" unless defined $log;
   #print @strings;
   print $log @strings;
}

sub json_to_perl($) {
   my($json_string) = @_;
   JSON->new->utf8->decode($json_string);
}

sub perl_to_json($) {
   my($array_ref) = @_;
   JSON->new->utf8->allow_nonref->pretty->encode($array_ref);
}

sub compute_new_time($$) {
   my($original_time, $requirement_type) = @_;
   #$original_time = max(60000, $original_time);
   int max 0, $original_time * $settings{"parts_${requirement_type}_time"};
}

sub compute_time_from_difficulty($$) {
   my($difficulty, $requirement_type) = @_;
   ($difficulty + 1) * 30000;
}

sub has_standard_difficulty($) {
   my($node) = @_;
   exists $node->{difficulty};
}

sub has_difficulty_in_requirements($$) {
   my($node, $requirement_type) = @_;
   exists $node->{requirements}->{$requirement_type}->{skills}
          && any { "mechanics" } $node->{requirements}->{$requirement_type}->{skills};
}

sub has_time_in_requirements($$) {
   my($node, $requirement_type) = @_;
   exists $node->{requirements}->{$requirement_type}->{time};
}

sub has_parent($) {
   my($node) = @_;
   exists $node->{"copy-from"};
}

sub get_parent($$) {
   my($json, $node) = @_;
   die perl_to_json $node unless has_parent $node;

   my $copy_from = $node->{"copy-from"};
   first_value { $_->{id} eq $copy_from || $_->{abstract} eq $copy_from } @$json
}

sub get_id($) {
   my($node) = @_;
   $node->{id} ? $node->{id} : $node->{result} ? $node->{result} : $node->{abstract};
}

sub get_standard_difficulty($) {
   my($node) = @_;
   die perl_to_json $node unless has_standard_difficulty $node;

   $node->{difficulty};
}

sub get_difficulty_from_requirements($$) {
   my($node, $requirement_type) = @_;
   die perl_to_json $node unless has_difficulty_in_requirements $node, $requirement_type;

   $node->{requirements}->{$requirement_type}->{skills}->[
      first_index { "mechanics" } $node->{requirements}->{$requirement_type}->{skills}
      + 1
   ]->[1];
}

sub get_time_from_requirements($$) {
   my($node, $requirement_type) = @_;
   die perl_to_json $node unless has_time_in_requirements $node, $requirement_type;

   $node->{requirements}->{$requirement_type}->{time};
}

sub set_time_to_requirements($$$) {
   my($node, $requirement_type, $time) = @_;

   $node->{requirements}->{$requirement_type}->{time} = int $time;
}

sub set_difficulty_to_requirements($$$) {
   my($node, $requirement_type, $difficulty) = @_;

   push @{ $node->{requirements}->{$requirement_type}->{skills} }, [ "mechanics", int $difficulty ];
}

sub check_flag($$) {
   my($node, $flag) = @_;
   any { $flag } $node->{flags};
}

#------------------------------------------------------------

if(-d "$game_path/data.bk") {
   if(any { "--restore" } @ARGV) {
      say "Restoring original files...";
      dircopy "$game_path/data.bk/json", "$game_path/data/json";
      dircopy "$game_path/data.bk/mods", "$game_path/data/mods";
      remove_tree "$game_path/data.bk";
      say "Done";
   } else {
      say "Game files already modified, try --restore first";
   }

   exit;
} else {
   report "Backup original files to '$game_path/data.bk'...";
   dircopy "$game_path/data/json", "$game_path/data.bk/json";
   dircopy "$game_path/data/mods", "$game_path/data.bk/mods";
   report "Done";
}

#------------------------------------------------------------

my %count = (checked => 0, modified => 0, parts => 0, books => 0, mutations => 0);

for my $file_path (
   File::Find::Rule->file->name("*.json")->in(
      "$game_path/data/json/vehicleparts",
      "$game_path/data/json/items/book",
      "$game_path/data/json/recipes",
      "$game_path/data/mods"
   ),
   "$game_path/data/json/mutations.json"
) {
   $count{checked}++;

   my $text = read_file $file_path;
   my $file_modified = 0;

   my $json = json_to_perl($text);
   next if ref $json ne "ARRAY";

   for my $node (@$json) {
      next if ref $node ne "HASH";
      next unless exists $node->{type};

      my $id = get_id($node);
      my $node_modified = 0;

      given($node->{type}) {
         when("vehicle_part") {
            for my $requirement_type ("install", "repair", "removal") {
               my $original_difficulty;
               my $original_time;

               if(has_difficulty_in_requirements $node, $requirement_type) {
                  $original_difficulty = get_difficulty_from_requirements $node, $requirement_type;
               } elsif (has_standard_difficulty $node) {
                  $original_difficulty = get_standard_difficulty $node;
               } elsif(has_parent $node) {
                  my $parent_node = get_parent($json, $node);
                  if(has_standard_difficulty $parent_node) {
                     $original_difficulty = get_standard_difficulty $parent_node;
                  } elsif(has_difficulty_in_requirements $parent_node, $requirement_type) {
                     $original_difficulty = get_difficulty_from_requirements $parent_node,
                                                                             $requirement_type;
                  } else {
                     report "Part '$id' has no difficulty";
                  }
               }

               die if defined $original_difficulty && length $original_difficulty == 0;

               if(has_time_in_requirements $node, $requirement_type) {
                  $original_time = get_time_from_requirements $node, $requirement_type;
                  if(defined $original_difficulty) {
                     $original_time = min($original_time,
                                          compute_time_from_difficulty $original_difficulty,
                                                                       $requirement_type);
                  }
               } elsif(defined $original_difficulty) {
                  $original_time = compute_time_from_difficulty $original_difficulty,
                                                                $requirement_type;
               }

               if(defined $original_time) {
                  set_time_to_requirements $node,
                                           $requirement_type,
                                           compute_new_time $original_time, $requirement_type;

                  if(defined $original_difficulty && !has_difficulty_in_requirements $node, $requirement_type) {
                     set_difficulty_to_requirements $node,
                                                    $requirement_type,
                                                    $original_difficulty;
                  }

                  report sprintf "Part '%s'%s (difficulty: %d): change $requirement_type time %d -> %d",
                     $id,
                     has_parent($node)?" (parent: '" . get_id(get_parent($json, $node)) . "')":"",
                     $original_difficulty,
                     $original_time,
                     compute_new_time $original_time, $requirement_type;

                  $file_modified = 1;
                  $node_modified = 1;
                  $count{parts}++;
               } elsif(defined $original_difficulty && !exists $node->{abstract}) {
                  report "Can't determine $requirement_type time for '$id'";
               }
            }
         }
         when("BOOK") {
            if(exists $node->{time}) {
               my $old_time = $node->{time};
               my $new_time = int($old_time * $settings{books_time});
               $new_time = 1 if $new_time < 1 && $old_time >= 1;
               $node->{time} = $new_time;

               report "Book '$node->{id}': change reading time $old_time -> $new_time";

               $file_modified = 1;
               $node_modified = 1;
               $count{books}++;
            }
         }
         when("recipe") {
            if(exists $node->{time}) {
               my $id = get_id($node);
               my $old_time = $node->{time};
               my $new_time = int($old_time * $settings{books_time});
               $new_time = 1 if $new_time < 1 && $old_time >= 1;
               $node->{time} = $new_time;

               report "Recipe '$id': change craft time $old_time -> $new_time";

               $file_modified = 1;
               $node_modified = 1;
               $count{recipes}++;
            } else {
               report "Recipe '$id' has no time";
            }
         }
         when("mutation") {
            if($node->{id} eq $settings{sleep_mutation_id}) {
               $node->{fatigue_regen_modifier} = $settings{sleep_acceliration};

               report "Mutation '$node->{id}': faster sleep effect added";

               $file_modified = 1;
               $node_modified = 1;
               $count{mutations}++;
            }
         }
      }

      if($node_modified) {
         #$node->{MODIFIED} = $JSON::true;
      }
   }

   for my $node (grep { ref $_ eq "HASH" && $_->{type} eq "vehicle_part" } @$json) {
      for my $requirement_type ("install", "repair", "removal") {
         if(exists $node->{requirements}->{$requirement_type} && %{$node->{requirements}->{$requirement_type}} == 0) {
            delete $node->{requirements}->{$requirement_type};
         }
      }
   }

   if($file_modified) {
      say "Edit file '$file_path'";
      write_file $file_path, perl_to_json $json;

      $count{modified}++;
   }
}

#------------------------------------------------------------

report "\nFiles checked: $count{checked}",
       "Files edited: $count{modified}",
       "Parts: $count{parts}",
       "Books: $count{books}",
       "Recipes: $count{recipes}",
       "Mutations: $count{mutations}";

#------------------------------------------------------------