#!/usr/bin/perl

# calculate how many of X is required to get Y


# TODO:    replace my ad-hoc terms with the real terms used in the game...   if you mouse-over items that are in your inventory, you can see the real terms:
#
#
#   - sediment      (I had "gravel")
#   - stone         (I had "squareblock")
#   - wood          (I had "log")
#   - weed          (I had "seaweed")
#   - glow_bulb     (I had "greenglow")
#   - energy        (I had "protein")
#   - gas           (I had "blueball")
#
#   - mechanical_part   (I had "bolt")
#   - gold
#   - diamond
#
#   - light         (I had "flashlight")
#   - suit          (I had "helmet")
#   - boots         (I had "flippers")
#   - laser         (got it right)
#   - air_tank      (got it right)
#
#   - lantern       (got it right)
#   - light_energy_charger
#   - crafting_station
#   - air_cabinet


    use strict;
    use warnings;

    use Carp;
    use List::Util;
    use POSIX;

    use Data::Dumper;
    #use Devel::Comments;           # uncomment this during development to enable the ### debugging statements


    @ARGV = ('blueball', 'engine');         # USE DURING TESTING ONLY


################################################################################
################################################################################
# These are the raw rules, as given directly in the game
#
# To make verification easier:
#       - recipes are put in groups of three, where each group is a line that's
#         mentioned in the game's help page.
#       - the ingredients are mentioned in the order that's encountered going
#         left-to-right and top-to-bottom
#
# Symbol names need to be VERY consistently used:
#       - no plurals, only use the singular form
#       - no spaces in between  (underscores are okay though)
#       - l1_airtank means "level 1 airtank", l4_helmet means "level 4 helmet"
# 
# Lexer:
#       - it is completely space-based
#       - spaces are REQUIRED around each operator, and symbol
#
# Syntax:
#       - should be mostly obvious
my $rule_lineno = __LINE__ + 2;
my $rules = <<'EOF';

    # these things need to be separately defined, since they're only referenced once...   we want to
    # be able to easily find misspellings below, so we don't allow auto-declaration
    declare airtent
    declare engine
    declare lantern
    declare workbench
    declare charger


    seaweed = 5 dirt
    gravel = 2 dirt
    greenglow = 2 seaweed

    greenglow = squareblock
    greenglow = 2 log
    greenglow = 2 gravel
    
    greenglow = 4 dirt
    mushroom = 5 seaweed
    blueball = 4 mushroom

    squareblock = 2 seaweed
    log = greenglow + 3 seaweed
    protein = greenglow + 4 squareblock + mushroom

    coal = protein + 2 dirt + 3 log
    coal = 6 log
    iron = coal + protein + 3 squareblock + dirt

    bolt = 3 squareblock + protein + iron
    gold = protein + greenglow + 4 iron
    diamond = 2 gold + protein + 2 blueball

    l1_airtank = 4 coal + protein + 4 blueball
    l2_airtank = 2 l1_airtank + 4 iron + protein
    l3_airtank = 2 l2_airtank + 2 gold + 2 iron + protein

    l4_airtank = 2 l3_airtank + 2 iron + bolt + diamond
    l1_helmet = 4 coal + 4 dirt + protein
    l2_helmet = l1_helmet + 2 iron + 2 bolt

    l3_helmet = l2_helmet + 2 gold + 2 iron
    l4_helmet = l3_helmet + 2 diamond + 2 protein
    l1_flipper = 2 seaweed + 2 coal + protein

    l2_flipper = l1_flipper + 3 seaweed + protein
    l3_flipper = l2_flipper + 2 gold + 2 seaweed + protein
    l4_flipper = l3_flipper + 2 diamond + 2 seaweed + protein

    l1_laser = 3 protein
    l2_laser = 3 l1_laser
    l3_laser = l2_laser + 2 gold

    l4_laser = l3_laser + 2 diamond + greenglow
    l1_flashlight = 4 greenglow + protein
    l2_flashlight = l1_flashlight + 4 protein

    l3_flashlight = l2_flashlight + 4 gold
    l4_flashlight = l3_flashlight + 8 l1_flashlight
    airtent = l1_airtank + 3 blueball

    charger = 3 protein + 2 greenglow
    workbench = 4 log + bolt
    lantern = protein + greenglow

    engine = l4_airtank + l4_helmet + l4_flipper + l4_laser + l4_flashlight + 2 diamond + 3 bolt



EOF


# for all items in a given tier, once you go through any possible rule-expansion, all remaining items will
# be from tiers that are below that  (eg. $tier[2], after expansion, will only include items from
# $tier[1] or $tier[0])
my @tiers = (
    [qw[ dirt ]],
    [qw[ seaweed gravel ]],
    [qw[ mushroom ]],
    [qw[ blueball squareblock ]],
    [qw[ INTERDEPENDENT log greenglow ]],
    [qw[ protein ]],
    [qw[ coal ]],
    [qw[ iron ]],
    [qw[ gold bolt ]],
    [qw[ diamond ]],
    [qw[ lantern workbench charger ]],
    [qw[ l1_airtank l1_helmet l1_flipper l1_laser l1_flashlight ]],
    [qw[ l2_airtank l2_helmet l2_flipper l2_laser l2_flashlight airtent ]],
    [qw[ l3_airtank l3_helmet l3_flipper l3_laser l3_flashlight ]],
    [qw[ l4_airtank l4_helmet l4_flipper l4_laser l4_flashlight ]],
    [qw[ engine ]],
);
#print Dumper \@tiers; exit;

## parse rules
my @rules = parse_rules($rules, $rule_lineno);
my %rules = index_rules(\@rules);

# check that the above tiers are actually tiers...  if anything results in producing things from
# higher tiers, then the proposed tier structure above is wrong, and a human needs to fix it
my %tiers = assert_check_tiers(\%rules, \@tiers);
            #   ^^^ okay, we're somewhat improper here, and have an 'assert' routine actually do useful work for us, by returning %tiers
            #           Ideally the functionality would be separted into two pieces, but meh.

################################################################################
################################################################################




################################################################################
########[ MAIN LOOP ]###########################################################
################################################################################



## parse command-line
if (@ARGV < 2) {
    die "syntax:   $0 <from> <to>\n";
}
my ($from_ingred, $to_ingred) = @ARGV;
die_unless_valid_symbol($from_ingred);
die_unless_valid_symbol($to_ingred);


POSIX::nice(20);

## search backwards
#print Dumper \%rules; exit;
my $from_tier = $tiers{$from_ingred};
my @possibilities = search_backwards_from($to_ingred, $from_ingred, $from_tier, \%rules);

exit;



################################################################################
########[ SEARCH ]##############################################################
################################################################################

# change @rules into a %rules, with the $LHS as the key
sub index_rules {
    my $rules = shift;
    my %rules;
    foreach my $rule (@$rules) {
        my ($LHS, $RHS) = @$rule;
        push(@{$rules{$LHS}}, $RHS);
    }
    return %rules;
}

sub search_backwards_from {
    my ($to_ingred, $from_ingred, $reduce_to_tier, $rules) = @_;

    my @queue = ([[1, $to_ingred]]);
    my @possibilities;
    my %seen;
    
    my $DEBUG = 1;
    
    my $max_target = 0;
    my $min_target = 9999;

    while (@queue) {
        ## pull one of the queue
        my @exploring = @{ shift @queue };
        @exploring = sort_ingredlist(@exploring);       # this probably isn't necessary, but just in case....
        assert_ingredlist_no_duplicates(@exploring);
        #print Dumper \@exploring; exit;
        my $exploring_ingreds = ingreds_key(\@exploring);
        #print "\$exploring_ingreds = >>$exploring_ingreds<<\n"; exit;
        if ($seen{$exploring_ingreds}) {
            assert_ingredlist_collision_is_the_same(\@exploring, $seen{$exploring_ingreds});
            next;
        }
        $seen{$exploring_ingreds} = \@exploring;
        push(@possibilities, \@exploring);


        # slowly reduce the target tier.   Basically, expand the highest-tier ingredients first.
        #print Dumper \@exploring; exit;
        my $max_tier = ingredlist_max_tier(@exploring);
        my $target_tier = $max_tier - 1;
        if ($target_tier <= $reduce_to_tier) {      # tada, we've arrived!
            my $count_target;
            foreach my $el (@exploring) {
                if ($el->[1] eq $from_ingred) {
                    $count_target = $el->[0];
                    last;
                }
            }
            next unless defined($count_target);
            ($min_target) = List::Util::min($min_target, $count_target);
            ($max_target) = List::Util::max($max_target, $count_target);
            print "$min_target - $max_target\n";
            next;
        }

        my $queue_size = scalar(@queue);
        #print "---- [$target_tier, $queue_size]   ", pretty_print_ingredlist(\@exploring), " ----\n"      if $DEBUG;

        ## try to expand each ingredient, in turn
        for (my $ctr=0; $ctr<=$#exploring; $ctr++) {
            my $exploring = $exploring[$ctr];
            my ($qty_in, $ingred_in) = @$exploring;

            # if we've reached the desired tier, then there's no need to continue expanding
            next if ($tiers{$ingred_in} <= $reduce_to_tier);

            foreach my $expansion (@{$rules{$ingred_in}}) {
                ## clone
                my @new_exploring = map { [ @$_ ] } @exploring;
                ## remove the one ingredient that we're expanding
                splice(@new_exploring, $ctr, 1);
                ## add the new ingredients that it's expanded to
                foreach my $expand_ingred (@$expansion) {
                    my ($qty_out, $ingred_out) = @$expand_ingred;
                    my $found = 0;
                    foreach my $search (@new_exploring) {
                        if ($search->[1] eq $ingred_out) {
                            $search->[0] += $qty_in * $qty_out;
                            $found++;
                            last;
                        }
                    }
                    if (!$found) {
                        push(@new_exploring, [$qty_in * $qty_out, $ingred_out]);
                    }
                }
                ## sort by ingredient-name, since we may have appended some to the end
                #@new_exploring = sort {$a->[1] cmp $b->[1]} @new_exploring;
                @new_exploring = sort_ingredlist(@new_exploring);

                #print "\t", pretty_print_ingredlist(\@new_exploring), "\n"      if $DEBUG;

                ## add it to the queue
                my $new_exploring_ingreds = ingreds_key(\@new_exploring);
                if (!$seen{$new_exploring_ingreds}) {
                    #push(@queue, \@new_exploring);
                    unshift(@queue, \@new_exploring);
                } else {
                    assert_ingredlist_collision_is_the_same(\@exploring, $seen{$exploring_ingreds});
                }
            }
        }

        #sleep(1)        if $DEBUG;
        select undef, undef, undef, 0.01;
    }
}


# given a list of ingredients:
#               ([$qty1, $ingred1],
#                [$qty2, $ingred2],
#                ...);
# this routine returns a string that is:
#       "$ingred1|$ingred2|..."
sub ingreds_key {
    my $ingreds = shift;
    assert_ingredlist_sorted(@$ingreds);
    my $ingreds_key = join("|", sort map {$_->[1]} @$ingreds);
    #my $ingreds_key = join("|", map {$_->[0] . " " . $_->[1]} @$ingreds);
}




################################################################################
########[ LEXER + PARSER ]######################################################
################################################################################

sub parse_rules {
    my ($rules, $rule_lineno) = @_;
    
    my @rules;

    my @lines = split /\n/s, $rules;
    #foreach my $line (split /[\n\r]+/s, $rules) {
    for (my $ctr=0; $ctr<=$#lines; $ctr++) {
        my $line = $lines[$ctr];
        my $line_number = $rule_lineno + $ctr;
        $line =~ s/#.*//s;
        next unless ($line =~ /\S/s);
        my @tokens = split ' ', $line;
        #print Dumper \@tokens;
        my $rule = process_tokens($line_number, @tokens);
        push(@rules, $rule)     if $rule;
    }
    #print Dumper \@rules; exit;
    #pretty_print_rules(\@rules); exit;

    #display_symbol_statistics();
    #error_single_use_symbols();

    return @rules;
}


sub process_tokens {
    my ($line_number, @tokens) = @_;

    my $orig_line = join " ", @tokens;

    if (@tokens == 2 && $tokens[0] eq 'declare') {
        is_symbol($tokens[1], $line_number, 99);
        return;
    }

    warn "[$line_number]  Syntax error:  Every rule must be   <symbol> = <expression>\n\t$orig_line\n" and return
        unless ($tokens[1] eq '=');

    # process the left-hand-side
    my $LHS = shift @tokens;
    is_symbol($LHS, $line_number)       or return;
    shift @tokens;      # discard equals sign

    # process the right-hand-side
    my @ingredients;            # this is the main output of the following for-loop
    my $multiplier = 1;
    my $ready_for_multiplier = 1;
    my $ready_for_symbol = 1;
    my $already_processed_symbol = 0;
    foreach my $token (@tokens) {
        if ($token =~ /^\d+$/) {
            if (!$ready_for_multiplier) {
                warn "[$line_number] unexpected number '$token'\n\t$orig_line\n" and return;
            }
            $multiplier = int($token);
            $ready_for_multiplier = 0;
        } elsif ($token eq '+') {
            if (!$already_processed_symbol) {
                warn "[$line_number] unexpected plus-operator\n\t$orig_line\n"   and return;
            }
            $multiplier = 1;
            $ready_for_multiplier = 1;
            $ready_for_symbol = 1;
            $already_processed_symbol = 0;
        } else {
            is_symbol($token, $line_number)     or return;
            if (!$ready_for_symbol) {
                warn "[$line_number] unexpected symbol '$token'\n\t$orig_line\n"   and return;
            }
            push(@ingredients, [$multiplier, $token]);
            $ready_for_multiplier = 0;
            $ready_for_symbol = 0;
            $already_processed_symbol = 1;
        }
    }
    #push(@$rules, [$LHS, \@ingredients]);
    return [$LHS, \@ingredients];
}


BEGIN {
    my %symbol_count;

    sub is_symbol {
        my ($token, $line_number, $weight) = @_;
        $weight = 1   if (!defined($weight));
        $symbol_count{$token} += $weight;
        if ($token =~ /^[a-z][a-z_0-9]*$/s) {
            return 1;
        } else {
            warn "[$line_number]  '$token' is not a valid symbol name\n";
            return 0;
        }
    }

    sub display_symbol_statistics {
        my @symbols = sort {$symbol_count{$b} <=> $symbol_count{$a}} keys %symbol_count;
        foreach my $symbol (@symbols) {
            printf "%4d  %s\n", $symbol_count{$symbol}, $symbol;
        }
    }

    # if there are any symbols that were only used once, then mention to the user that it might be a
    # misspelling
    sub error_single_use_symbols {
        my $num_errors = 0;
        while (my ($var, $val) = each %symbol_count)  {
            if ($val <= 1) {
                $num_errors++;
                warn "Symbol '$var' was only used once.  It may be misspelled.  If it's correct, you must use a 'delcare' line for this symbol.\n";
            }
        }
        die "\n"    if ($num_errors);
    }

    sub die_unless_valid_symbol {
        my $symbol = shift;
        return if ($symbol_count{$symbol} && $symbol_count{$symbol} > 1);
        die "INVALID INGREDIENT '$symbol'.  Avaliable ingredients are:\n\t"
                . join("\n\t", sort keys %symbol_count) . "\n";
    }
}


sub pretty_print_rules {
    my $rules = shift;

    foreach my $rule (@$rules) {
        my ($LHS, $RHS) = @$rule;
        print "'$LHS' = ";
        print pretty_print_ingredlist($RHS, 1);
        print "\n";
    }
}



# an ingredient-list is always of the form:
#               ([$qty1, $ingred1],
#                [$qty2, $ingred2],
#                ...);
sub pretty_print_ingredlist {
    my ($ingred_list, $use_quotes) = @_;
                # $use_quotes is optional....  if specified, and it's true, it will wrap ingred-names in single-quotes
    my $quote = $use_quotes ? "'" : "";

    my $is_first = 1;
    my @ingreds_out;
    foreach my $ingred (@$ingred_list) {
        my $ingred_out = '';
        #print " + "      if (!$is_first);
        my ($qty, $symbol) = @$ingred;
        if ($qty != 1) {
            $ingred_out = "$qty ";
        }
        $ingred_out .= "$quote$symbol$quote";
        #print "'$symbol'";
        push(@ingreds_out, $ingred_out);
        $is_first = 0;
    }
    return join(" + ", @ingreds_out);
}


sub sort_ingredlist {
    my @ingred_list = @_;
    @ingred_list = sort {$a->[1] cmp $b->[1]} @ingred_list;
}


sub ingredlist_max_tier {
    my @ingred_list = @_;
    my @tiers = map {$tiers{$_->[1]}} @ingred_list;
    return List::Util::max(@tiers);
}


# ingredient-lists should never have duplicate ingredient names...  check that this assertion is true
sub assert_ingredlist_no_duplicates {
    my @ingred_list = @_;
    my %seen;
    foreach my $listitem (@ingred_list) {
        my ($qty, $ingred) = @$listitem;
        if (exists $seen{$ingred}) {
            croak "ERROR: duplicate ingredient '$ingred' seen in ingredient-list:\n\t" .
                    pretty_print_ingredlist(\@ingred_list) . "\n\n\t";
        }
        $seen{$ingred}++;
    }
}

# When we get a hash-collision, based on ingreds_key(), the collision SHOULD have the same
# ingredient-count.  Check that this assertion is true.
sub assert_ingredlist_collision_is_the_same {
    my ($new, $old) = @_;

    if (scalar(@$new) != scalar(@$old)) {
        croak "ERROR: ingredient-lists are different lengths\n";
    }

    my @differences;
    for (my $ctr=0; $ctr<scalar(@$new); $ctr++) {
        if ($new->[$ctr][0] != $old->[$ctr][0]) {
            push(@differences, $old->[$ctr][1]);
            #croak "ERROR: ingred-list collision has mismatched quantities on '$new->[$ctr][1]':\n"
            #            . pretty_print_ingredlist($new) . "\n"
            #            . pretty_print_ingredlist($old) . "\n\t";
        }
    }
    # If there are zero differences, or two or more differences, then we're fine.
    #           (two differences can occur when you can get to the same list by adding one ingredient and subtracting another)
    # The only time it's a problem is if there is just one difference.  That shouldn't be able to happen.
    if (@differences == 1) {
        croak "ERROR: ingred-list collision has mismatched quantities on '$differences[1]':\n"
                    . pretty_print_ingredlist($new) . "\n"
                    . pretty_print_ingredlist($old) . "\n\t";
    }
}


# check that the proposed tiers are actually tiers...  if anything results in producing things from
# higher tiers, then the proposed tier structure above is wrong, and a human needs to fix it
sub assert_check_tiers {
    my %rules = %{ shift @_ };
    my @tiers = @{ shift @_ };

    ## create the   ingredient=>tier-number   mapping
    my %tiers;
    my @interdependent;
    for (my $tiernum=0; $tiernum<scalar(@tiers); $tiernum++) {
        foreach my $ingred (@{$tiers[$tiernum]}) {
            if ($ingred eq 'INTERDEPENDENT') {      
                $interdependent[$tiernum] = 1;
                next;       # INTERDEPENDENT is not an ingredient, but a flag that indicates a different type of tier
            }
            $tiers{$ingred} = $tiernum;
        }
    }

    ## check the assertion on each tier
    my $num_problems = 0;
    for (my $tiernum_in=0; $tiernum_in<scalar(@tiers); $tiernum_in++) {
        foreach my $ingred_in (@{$tiers[$tiernum_in]}) {
            next if ($ingred_in eq 'INTERDEPENDENT');
            foreach my $rule (@{$rules{$ingred_in}}) {
                my @ingreds_out = uniq(map {$_->[1]} @$rule);
                foreach my $ingred_out (@ingreds_out) {
                    my $tiernum_out = $tiers{$ingred_out};
                    if (!defined($tiernum_out)) {
                        print Dumper [$ingred_out, $tiernum_out], \%tiers;
                        die "Ingredient '$ingred_out' isn't found on any tier.\n\t";
                    }
                    if ($tiernum_out >= $tiernum_in) {
                        if ($tiernum_out == $tiernum_in) {
                            next if ($interdependent[$tiernum_in]);     # ignore interdependencies on the same level, if that tier is explicitely marked as such
                            print "$ingred_in   doesn't belong on its tier, because of input-ingredient    $ingred_out, which is on the same tier\n";
                        } else {
                            print "$ingred_in   doesn't belong on its tier, because of input-ingredient    $ingred_out, which is on a higher tier\n";
                        }
                        $num_problems++;
                    }
                }
            }
        }
    }

    exit if ($num_problems > 0);

    return %tiers;
}


# the ingredlist passed in is expected to be sorted at this point
sub assert_ingredlist_sorted {
    my @ingredlist = @_;
    return unless @ingredlist;
    my $last = shift @ingredlist;
    foreach my $ingred (@ingredlist) {
        if ($last->[1] gt $ingred->[1]) {
            croak "ASSERTION ERROR: ingred-list is not sorted  ($last > $ingred)";
        }
        $last = $ingred;
    }
}



# Removes duplicate elements from a list
sub uniq {my %seen; grep {!$seen{$_}++} @_}