DouKaku?

use strict;

sub solve {
    my ($ceil) = @_;

    # 一番目と二番目の条件から組み合わせを絞り込む。
    my $pairs = [];
    {
        # 最初に二人が取り得る組み合わせ。
        my $la = {};
        my $lb = {};
        for (my $i = 1; $i <= $ceil; $i++) {
            for (my $j = $i; $j <= $ceil; $j++) {
                my $p = $i * $j;
                if ($la->{$p}) {
                    $la->{$p}[$#{$la->{$p}} + 1] = [$i, $j];
                } else {
                    $la->{$p} = [[$i, $j]];
                }
                my $s = $i + $j;
                if ($lb->{$s}) {
                    $lb->{$s}[$#{$lb->{$s}} + 1] = [$i, $j];
                } else {
                    $lb->{$s} = [[$i, $j]];
                }
            }
        }

        # A さんも B さんも教えられた数字(積と和)から
        # 判定出来ない。
        foreach my $k (keys(%{$la})) {
            delete($la->{$k}) if ($#{$la->{$k}} == 0);
        }

        foreach my $k (keys(%{$lb})) {
            delete($lb->{$k}) if ($#{$lb->{$k}} == 0);
        }

        # B さんは A が判定不能だと云う事を判っていた。
        # つまり和を分解して得られる組み合わせの全てに於いて、
        # その積の取り得る組み合わせが複数在ると云う事。
        foreach my $k (keys(%{$lb})) {
            foreach my $e (@{$lb->{$k}}) {
                ($la->{$e->[0] * $e->[1]}) || delete($lb->{$k});
            }
        }

        foreach my $k (keys(%{$lb})) {
            foreach my $e (@{$lb->{$k}}) {
                $pairs->[$#{$pairs} + 1] = $e;
            }
        }
    }

    # それを聞いた A さんは判ったのであるから、
    # 残りの組み合わせに積の重複は無い筈。
    {
        my $t = {};
        foreach my $e (@{$pairs}) {
            my $p = $e->[0] * $e->[1];
            $t->{$p} && $t->{$p}++ || ($t->{$p} = 1);
        }
        my $r = [];
        foreach my $e (@{$pairs}) {
            my $p = $e->[0] * $e->[1];
            ($t->{$p} == 1) && ($r->[$#{$r} + 1] = $e);
        }

        $pairs = $r;
    }

    # A さんが判ったと聞いた B さんも判つたので、
    # 残りの組み合わせに和の重複は無い筈。
    {
        my $t = {};
        foreach my $e (@{$pairs}) {
            my $s = $e->[0] + $e->[1];
            $t->{$s} && $t->{$s}++ || ($t->{$s} = 1);
        }
        my $r = [];
        foreach my $e (@{$pairs}) {
            my $s = $e->[0] + $e->[1];
            ($t->{$s} == 1) && ($r->[$#{$r} + 1] = $e);
        }

        $pairs = $r;
    }

    return $pairs;
}

foreach my $n (1..100) {
    printf("%4d: ", $n);
    my $e = &solve($n);
    if (! @{$e}) {
        printf("None");
    } else {
        foreach my $f (sort {($a->[0] <=> $b->[0]) || ($a->[1] <=> $b->[1])} @{$e}) {
            printf("[%2d, %2d], ", @{$f});
        }
    }
    print("\n");
}