D.pl

#! /usr/bin/env perl

use v5.14;
use strict;
use warnings;
use List::Util qw{first sum};
use IO::Handle;

sub debug(@) {
    return unless $ENV{DEBUG};
    STDERR->print(@_)
}

sub read_line {
    my $line = scalar <>;
    return () unless defined $line;
    chomp $line;
    return $line;
}

sub add_keys(\@@) {
    my ($keys, @new_keys) = @_;
    for (@new_keys) {
        $$keys[$_] += 1;
    }
    for (@$keys) { $_ //= 0 }
}

sub del_keys(\@@) {
    my ($keys, @old_keys) = @_;
    for (@old_keys) {
        $$keys[$_] -= 1;
    }
    for (@$keys) { $_ //= 0 }
}

sub take_key(\@$) {
    my ($keys, $type) = @_;
    if ($$keys[$type] && $$keys[$type] > 0) {
        $$keys[$type]--;
        return 1;
    }
    return ();
}

sub debug_keys {
    my (@keys) = @_;
    if ($ENV{DEBUG}) {
        debug "Keys on hand: ";
        my @list;
        for (1..@keys) {
            next if !defined $keys[$_] || $keys[$_] == 0;
            push @list, "${_}x$keys[$_]";
        }
        debug join ' ', @list;
        debug "\n";
    }
}

sub sanity_check {
    my ($start_keys, $start_chests) = @_;
    my @keys = @$start_keys;
    my @chests = @$start_chests;

    my @needed_keys;

    for my $chest (@chests) {
        add_keys @keys, @{$chest}[1..(@$chest-1)] if @$chest > 1;
        $needed_keys[$$chest[0]] //= 0;
        $needed_keys[$$chest[0]] += 1;
    }

    for my $key (0..$#needed_keys) {
        if (($keys[$key] // 0) < ($needed_keys[$key] // 0)) {
            debug "MISSING type $key keys! Scenario needs $needed_keys[$key], only has $keys[$key]\n";
            return 0;
        }
    }
    return 1;
}

sub brute_force {
    my ($start_keys, $start_chests) = @_;
    return "IMPOSSIBLE" unless sanity_check($start_keys, $start_chests);
    my @keys   = @$start_keys;
    my @chests = @$start_chests;
    my @open;

    my $start = 0;
    my $opened = 0;
    my $step = 0;
    my @dont;
    my @result;

    my $next = 0;
    my $loop = 0;
    my $itercnt = 0;
    debug "Start solution for ", scalar @chests, " chests\n";
    debug_keys(@keys);
    while ($opened < @chests) {
        debug "Loop ", ++$itercnt, ", step $step, chest $next: ";
        die if $itercnt > 2000;
        if ($open[$next]) {
            debug "already open\n";
            $next += 1;
            if ($next >= @chests) {
                ++$loop;
                $next = 0;
            }
            next;
        }
        my $take_ok = 1;
        if ($dont[$step] && defined first { $_ == $next } @{$dont[$step]}) {
            debug "blacklisted by backtrack, step $step\n";
            $take_ok = 0;
        }
        
        if ($take_ok && $loop < 1 && @{$chests[$next]} < 2) {
            debug "biasing against chest $next as it has no key inside\n";
            $take_ok = -1;
        }
        if ($take_ok > 0 && take_key @keys, $chests[$next][0]) {
            debug "opened chest $next (key type $chests[$next][0])\n";
            $loop = 0;
            push @result, $next;
            if (@{$chests[$next]} > 1) {
                add_keys @keys, @{$chests[$next]}[1..(@{$chests[$next]}-1)];
            }
            $open[$next] = 1;
            $opened++;
            $step++;
            $next = 0;
            debug_keys(@keys);
        } else {
            debug "no key to open chest $next (need key type $chests[$next][0])\n" if $take_ok > 0;
            $next += 1;
            # check for loop, it's possible we get stuck in a loop where
            # the very last chest is already open
            my $keys = sum(@keys);
            if ($keys == 0 || $next >= @chests || $loop > 2) {
                if ($keys == 0 || $loop++ > 2) {
                    # backtrack
                    debug "No means to open any chest, backtracking!\n";
                    if (--$step < 0) {
                        debug "Impossible to backtrack\n";
                        # no more backtracking D:
                        return "IMPOSSIBLE";
                    }
                    $opened--;
                    splice @dont, $step+1 if @dont > $step;
                    $dont[$step] //= [];
                    for (@dont) { $_ //= [] }

                    my $bad = pop @result;
                    push @{$dont[$step]}, $bad;
                    $open[$bad] = 0;
                    add_keys @keys, $chests[$bad][0];
                    del_keys @keys, @{$chests[$bad]}[1..(@{$chests[$bad]}-1)] if @{$chests[$bad]} > 1;
                    $next = $bad + 1;
                    if ($ENV{DEBUG}) {
                        debug "Blacklisted chest ", $next-1, " for step $step\n";
                        debug "Blacklists: ";
                        for (0..@dont) {
                            next unless $dont[$_] && @{$dont[$_]};
                            debug "Step $_: ", join(' ', @{$dont[$_]}), "\n";
                        }
                        debug_keys(@keys);
                    }
                    $next = 0 if $next >= @chests;
                    $loop = 0;
                }
                $next = 0;
            }
            next;
        }
    }
    debug "Everything open!\n";
    return join ' ', map { $_ + 1 } @result;
}

my $cases = read_line;
for my $case (1..$cases) {
    my (undef, $chests) = split ' ', read_line;
    my @keys;
    add_keys @keys, split ' ', read_line;

    my @chests;
    for my $chest (1..$chests) {
        my ($type, undef, @rest) = split ' ', read_line;
        push @chests, [$type, @rest];
    }

    print "Case #$case: ", brute_force(\@keys, \@chests), "\n";
}