Boxes and pebbles exploration

boxes-and-pebbles.p6

class Conf {
    has @.boxes where *.all >= 0;
    method gist { "[$.boxes]" }
}

sub conf(@boxes) { Conf.new(:@boxes) }
sub n(Conf $c) { $c.boxes.elems }

sub REPL($line) {
    say "> $line";
    my $result = EVAL $line;
    say $result if defined $result;
}

REPL 'n(conf [2, 0])';

sub but(@list, &act) { my @new = @list; &act(@new); @new }
sub add($c, $to, $count) { conf $c.boxes.&but(*.[$to] += $count) }
sub remove($c, $from, $count) { conf $c.boxes.&but(*.[$from] -= $count) }

sub move($c, $from, $to) { $c.&remove($from, 2).&add($to, 1) }
my $OPTIMIZATION_1 = False;
sub moves-from($c, $from) {
    sub to_hostage($t) { $OPTIMIZATION_1 ?? $c.boxes[$t] == 0 !! True }
    (move($c, $from, $_) if to_hostage($_) for ^n($c))
}
my $OPTIMIZATION_2 = False;
sub moves($c) {
    sub lower_limit { $OPTIMIZATION_2 ?? 3 !! 2 }
    (moves-from($c, $_) if $c.boxes[$_] >= lower_limit for ^n($c))
}

REPL 'moves(conf [2, 0])';

sub has-empty-box($c) { so any($c.boxes) == 0 }

REPL 'has-empty-box(conf [2, 2, 2, 0])';
REPL 'has-empty-box(conf [2, 2, 2, 1])';

sub is-solvable($c) { !has-empty-box($c) || so is-solvable any moves $c }

REPL 'is-solvable(conf [2, 0])';
REPL 'is-solvable(conf [3, 0])';

sub tree-search($c, $indent = 0) {
    say "\x20" x 4 * $indent, $c;
    for moves($c) {
        tree-search($_, $indent + 1);
    }
}

REPL 'tree-search(conf [4, 0, 0])';

sub add-pebble($c, $to) { conf $c.boxes.&but(*.[$to] += 1) }
sub add-pebble-anywhere($c) { (add-pebble($c, $_) for ^n($c)) }

REPL 'add-pebble-anywhere(conf [2, 0])';

sub is-answer($c) { !is-solvable($c) && so is-solvable all add-pebble-anywhere($c) }

REPL 'is-answer(conf [2, 0])';
REPL 'is-answer(conf [4, 0, 0])';

sub hostages($c) { +$c.boxes.grep(0) }

REPL 'hostages(conf [2, 0])';
REPL 'hostages(conf [3, 0, 0])';

sub heroes($c) { [+] ($c.boxes »-» 1) »div» 2 »max» 0 }

REPL 'heroes(conf [2, 0])';
REPL 'heroes(conf [3, 3, 0])';

$OPTIMIZATION_1 = True;
REPL 'tree-search(conf [4, 0, 0])';

$OPTIMIZATION_2 = True;
REPL 'tree-search(conf [4, 0, 0])';

sub one-more-hostage-than-heroes($c) { hostages($c) == heroes($c) + 1 }

REPL 'one-more-hostage-than-heroes(conf [2, 0])';
REPL 'one-more-hostage-than-heroes(conf [3, 1, 0])';

sub random-box { Bool.pick ?? 0 !! (1..5).pick }

sub random-conf {
    my $n = (0..5).pick;
    conf [random-box() xx $n];
}

sub quickcheck(&prop, $N = 1000) {
    for ^$N {
        print "." if $_ %% 20;
        my $c = random-conf;
        return "Counterexample: $c.gist()" unless &prop($c);
    }
    return "All $N cases passed.";
}

sub infix:«⇒»($premise, $conclusion) { !$premise || $conclusion }

sub if-answer-then-one-more-hostage($c) {
    is-answer($c) ⇒ one-more-hostage-than-heroes($c);
}

REPL 'quickcheck &if-answer-then-one-more-hostage';

sub if-one-more-hostage-then-answer($c) {
    one-more-hostage-than-heroes($c) ⇒ is-answer($c);
}

REPL 'quickcheck &if-one-more-hostage-then-answer';

sub all-hostages-or-everyday-heroes($c) { so $c.boxes.all %% 2 }
sub if-one-more-hostage-and-all-hostages-or-everyday-heroes-then-answer($c) {
    (one-more-hostage-than-heroes($c)
        && all-hostages-or-everyday-heroes($c))
        ⇒ is-answer($c)
}

REPL 'quickcheck &if-one-more-hostage-and-all-hostages-or-everyday-heroes-then-answer';

sub one-more-hostage-and-all-hostages-or-everyday-heroes-means-answer($c) {
    (one-more-hostage-than-heroes($c)
        && all-hostages-or-everyday-heroes($c))
        == is-answer($c)
}

REPL 'quickcheck &one-more-hostage-and-all-hostages-or-everyday-heroes-means-answer';

sub pebbles-are-twice-boxes-minus-two-and-all-boxes-even-means-answer($c) {
    ([+]($c.boxes) == 2 * n($c) - 2 && so($c.boxes.all %% 2))
        == is-answer($c)
}

REPL 'quickcheck &pebbles-are-twice-boxes-minus-two-and-all-boxes-even-means-answer';

sub partitions($n) {
    uniq :as(*.Str), gather {
        take [$n];
        for 1..^$n -> $x {
            take ([($x, .list).sort] for partitions($n - $x));
        }
    }
}

sub double(@list) { @list »*» 2 }
sub pad(@list, $size) { [@list, 0 xx ($size - @list.elems)] }
sub all-answers($n) { (.reverse.&double.&pad($n) for partitions($n - 1)) }

sub array-cmp(@xs, @ys) { [||] @xs Z<=> @ys }

for 1..* -> $n {
    my @answers = all-answers($n).sort(&array-cmp);
    say "{@answers.elems} answers of size $n:";
    say "  ", .&conf for @answers;
}