批处理之家 » Perl » Bulls and Cows 猜数字游戏 搜索树生成算法

523066680 发表于 2018-9-14 11:48

Bulls and Cows 猜数字游戏 搜索树生成算法

[i=s] 本帖最后由 523066680 于 2018-9-14 12:06 编辑 [/i]

论坛曾经有过大量讨论，参考链接
[url]http://bbs.bathome.net/thread-44826-1-2.html[/url]
[url]http://bbs.bathome.net/thread-44983-1-1.html[/url]

同时参考 a20150604 提供的资料
[url=http://slovesnov.users.sourceforge.net/bullscows/bullscows.pdf]http://slovesnov.users.sourceforge.net/bullscows/bullscows.pdf[/url]
[url=http://slovesnov.users.sourceforge.net/index.php?bullscows_tree,english,avgBullsCows]http://slovesnov.users.sourceforge.net/index.php?bullscows_tree,english,avgBullsCows[/url]

523066680 发表于 2018-9-14 11:51

[i=s] 本帖最后由 523066680 于 2018-9-14 11:52 编辑 [/i]

代码是去年8月份的，现在分享出来

Perl （内联C，提高判断效率），分别生成 Perl 哈希结构 和 JSON 格式的搜索树。[code]=info
    生成最平均指标搜索树

    Code-by : 523066680
       Date : 2017-08
=cut

use List::Util qw/max sum/;

use JSON;
use Inline C;
use IO::Handle;
use Data::Dumper;
use File::Slurp;
use Time::HiRes qw/sleep/;
STDOUT->autoflush(1);
$Data::Dumper::Indent = 1;

#生成排列
our @orders;
permute( [0 .. 9] , [], 4, \@orders);

#生成树
print "Make tree\n";
my $tree;
$tree = { "0123" => {} };
maketree( $tree, \@orders, 0 );

#导出
print "Dump tree\n";
write_file("./Tree_avg2.perl.txt", Dumper $tree);
write_file("./Tree_avg2.json.txt", encode_json($tree) );

sub maketree
{
    our @orders;
    my $orders;
        my ($ref, $arr, $lv) = @_;
        my $AB = "00";
    my %keymap;
    my %hash;
    my $minkey;
    my $minval = 10000000;
    my $amount;

    if ($lv == 0) { $orders = ["0123"] }
    else          { $orders = \@orders }

    #根据参考指标，选出最优的测试项
    for my $e ( @$orders )
    {
        $amount = 0;
        %hash = ();

        for my $k ( @$arr )
        {
            bullcow( $k, $e, $AB );
            $hash{$AB}++;
        }

        #各项反馈下子集的平方和作为参考，值越小，分布越平坦，越均匀
        grep { $amount += $_ * $_ } values %hash;
        $amount = $amount/scalar(keys %hash);

        $keymap{$e} = $amount;

        if ($amount < $minval)
        {
                $minval = $amount;
                $minkey = $e;
        }
    }

    #如果筛选集中有符合条件的项，优先选择
    for my $k ( @$arr )
    {
            if ( $keymap{$k} == $minval ) { $minkey = $k; last; }
    }

    #建立反馈项和缩小集合组
    for my $k ( @$arr )
    {
        #删除 $minkey 以外的项（当前层）
        delete $ref->{$k} if ($k ne $minkey);

        #创建反馈项以及对应子集 / 反馈为 40 的项无需子集
        bullcow( $minkey, $k, $AB );   
        $ref->{$minkey}{$AB}{$k} = {} if ( $AB ne "40" );
    }
   
    for my $ab ( keys %{ $ref->{ $minkey } } )
    {
        printf " $lv -> $ab, %d\n", $#$arr;
        maketree( $ref->{$minkey}{$ab},  [ sort keys %{$ref->{$minkey}{$ab}} ], $lv+1 );
    }
}

sub permute
{
    my ( $a, $b, $n, $aref ) = @_;
    my $last = $#$a;

    if ( $#$b >= ($n-1) )
    {
        push @$aref, join("", @$b);
        return;
    }

    for my $idx ( 0 .. $last )
    {
        permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );
    }
}

__END__
__C__
void bullcow(char *stra, char *strb, char *AB)
{
    int idx;
    char a = '0';
    char b = '0';

    for ( idx = 0; idx < 4; idx++ )
    {
        if ( stra[idx] == strb[idx] )
            a++;
        else
            if ( strchr(stra, strb[idx]) != 0 )
            {
                b++;
            }
    }

    AB[0] = a;
    AB[1] = b;
}[/code][list]
[*][b]遍历测试.pl[/b]
[/list][code]use JSON;
use Data::Dumper;
use IO::Handle;
use File::Slurp;
use Time::HiRes qw/sleep time/;
STDOUT->autoflush(1);

$Data::Dumper::Indent = 1;

my $time_a = time();

our $nums = [];
our @orders_init;
our @orders;
permute( [0 .. 9] , [], 4, \@orders_init);

my $json;
my $tree;
my $struct = read_file("Tree_avg2.perl.txt");
my $tree = eval $struct;

my $iter = 0;
my $loopi = 0;
my $AB;
my $guess;
my $ref;
my %record;
my $times;

while ( $iter <= $#orders_init )
{
    $ref = $tree;
    $nums = $orders_init[$iter];
    print "Target Number: $nums\n";

    ($guess) = keys %$ref;
    #print $guess;

    $times = 0;
    SUB: while (1)
    {
        $loopi++;
        $times++;
        $AB = guess( $nums, $guess );
        print "[$AB] $guess\n";

        last SUB if ( $AB eq "40" );

        if ( exists $ref->{$guess}{$AB} )
        {
            $ref = $ref->{$guess}{$AB};
            ($guess) = keys %{$ref};
        }
        else
        {
            printf "there is some problem\n";
            exit;
        }

        if ($guess eq "")
        {
            printf "there is some problem\n";
            exit;
        }

        #print "-> $guess\n";
    }
    $record{$times}++;

    $iter++;
}

printf "Times: %d, average: %f \n", $loopi, $loopi/5040;

for my $k ( sort keys %record )
{
    printf "%s, %s\n", $k, $record{$k};
}

printf "%.3f\n", time()-$time_a;

sub guess
{
    my ($nums, $guess) = @_;
    my ($A, $B) = (0, 0);
    my $t;

    for my $i ( 0 .. 3 )
    {
        if ( substr($nums, $i, 1) eq substr($guess, $i, 1) )
        {
            $A++;
        }
        else
        {
            $t = substr($guess, $i, 1);
            $B++ if ( $nums =~/$t/ );
        }
        $i++;
    }

    return $A . $B;
}

sub permute
{
    my ( $a, $b, $n, $aref ) = @_;
    my $last = $#$a;

    if ( $#$b >= ($n-1) )
    {
        push @$aref, join("", @$b);
        return;
    }

    for my $idx ( 0 .. $last )
    {
        permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );
    }
}
[/code][list]
[*]统计结果
[/list]
[quote]Times: 26537, average: 5.265278
1, 1
2, 8
3, 66
4, 574
5, 2430
6, 1852
7, 108
8, 1[/quote]

523066680 发表于 2018-9-14 11:55

[i=s] 本帖最后由 523066680 于 2018-9-14 12:03 编辑 [/i]

Landy 方案[code]=info
    Landy方案

    Code-by : 523066680
       Date : 2017-08
=cut

use List::Util qw/max sum min/;

use JSON;
use Inline C;
use IO::Handle;
use Data::Dumper;
use File::Slurp;
use Time::HiRes qw/sleep/;
STDOUT->autoflush(1);
$Data::Dumper::Indent = 1;

#生成排列
our @orders;
permute( [0 .. 9] , [], 4, \@orders);

#生成树
print "Make tree\n";
my $tree;
$tree = { "0123" => {} };
maketree( $tree, \@orders, 0 );

#导出
print "Dump tree\n";
write_file("./Tree_landy.perl.txt", Dumper $tree);
write_file("./Tree_landy.json.txt", encode_json($tree) );

sub maketree
{
    our @orders;
    my $orders;
        my ($ref, $arr, $lv) = @_;
        my $AB = "00";
    my %keymap;
    my %hash;
    my $minkey;
    my $minval = 10000000;
    my $amount;

    if ($lv == 0) { $orders = ["0123"] }
    else          { $orders = \@orders }

    #根据参考指标，选出最优的测试项
    for my $e ( @$orders )
    {
        $amount = 0;
        %hash = ();

        for my $k ( @$arr )
        {
            bullcow( $k, $e, $AB );
            $hash{$AB}++;
        }

        #Times: 26439, average: 5.245833
        grep { $amount += $_ * landy($_) } values %hash;
        if ( exists $ref->{$e} ) { $amount -= 1.0 }

        $keymap{$e} = $amount;

        if ($amount < $minval)
        {
                $minval = $amount;
                $minkey = $e;
        }
    }

    #建立反馈项和缩小集合组
    for my $k ( @$arr )
    {
        #删除 $minkey 以外的项（当前层）
        delete $ref->{$k} if ($k ne $minkey);

        #创建反馈项以及对应子集 / 反馈为 40 的项无需子集
        bullcow( $minkey, $k, $AB );   
        $ref->{$minkey}{$AB}{$k} = {} if ( $AB ne "40" );
    }
   
    for my $ab ( keys %{ $ref->{ $minkey } } )
    {
        printf " $lv -> $ab, %d\n", $#$arr;
        maketree( $ref->{$minkey}{$ab},  [ sort keys %{$ref->{$minkey}{$ab}} ], $lv+1 );
    }
}

sub permute
{
    my ( $a, $b, $n, $aref ) = @_;
    my $last = $#$a;

    if ( $#$b >= ($n-1) )
    {
        push @$aref, join("", @$b);
        return;
    }

    for my $idx ( 0 .. $last )
    {
        permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );
    }
}

sub landy
{
    my $n = shift;
    my $x = 0.0;
    my $plus = 1.0;
    my $pow;

    return 1 if ($n == 1);

    while (1)
    {
        $pow = $x ** $x;

        if ( $pow < $n )
        {
            $x += $plus;
        }
        elsif ( $pow > $n )
        {
            $x -= $plus;
            $plus *= 0.1;
        }
        else
        {
            last;
        }

        last if ($plus < 0.000001);
    }

    return $x;
}
__END__
__C__
void bullcow(char *stra, char *strb, char *AB)
{
    int idx;
    char a = '0';
    char b = '0';

    for ( idx = 0; idx < 4; idx++ )
    {
        if ( stra[idx] == strb[idx] )
            a++;
        else
            if ( strchr(stra, strb[idx]) != 0 )
            {
                b++;
            }
    }

    AB[0] = a;
    AB[1] = b;
}[/code][list]
[*]结果
[/list]

[quote]Times: 26439, average: 5.245833
1, 1
2, 7
3, 79
4, 598
5, 2438
6, 1815
7, 101
8, 1[/quote]

523066680 发表于 2018-9-14 11:58

Log 估值方案[code]=info
    生成搜索树 - log估值方案

    Code-by : 523066680
       Date : 2017-08
=cut

use List::Util qw/max sum min/;

use JSON;
use Inline C;
use IO::Handle;
use Data::Dumper;
use File::Slurp;
use Time::HiRes qw/sleep/;
STDOUT->autoflush(1);
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;

#生成排列
our @orders;
permute( [0 .. 9] , [], 4, \@orders);

#生成树
print "Make tree\n";
my $tree;
$tree = { "0123" => {} };
maketree( $tree, \@orders, 0 );

#导出
print "Dump tree\n";
write_file("./Tree_log.perl.txt", Dumper $tree);
#write_file("./Tree_log.json.txt", encode_json($tree) );

sub maketree
{
    our @orders;
    my $orders;
        my ($ref, $arr, $lv) = @_;
        my $AB = "00";
    my %keymap;
    my %hash;
    my $minkey;
    my $minval = 10000000;
    my $amount;

    if ($lv == 0) { $orders = ["0123"] }
    else          { $orders = \@orders }

    #根据参考指标，选出最优的测试项
    for my $e ( @$orders )
    {
        $amount = 0;
        %hash = ();

        for my $k ( @$arr )
        {
            bullcow( $k, $e, $AB );
            $hash{$AB}++;
        }

        #5.243
        grep { $amount += $_ * log($_) } values %hash;
        #$amount /= scalar(keys %hash);

        #5.239
        if ( exists $ref->{$e} ) { $amount -= 2*log(2) }

        $keymap{$e} = $amount;

        #if ($amount < $minval) 26408
        if ($amount < $minval) #26405
        {
                $minval = $amount;
                $minkey = $e;
        }
    }

    #建立反馈项和缩小集合组
    for my $k ( @$arr )
    {
        #删除 $minkey 以外的项（当前层）
        delete $ref->{$k} if ($k ne $minkey);

        #创建反馈项以及对应子集 / 反馈为 40 的项无需子集
        bullcow( $minkey, $k, $AB );   
        $ref->{$minkey}{$AB}{$k} = {} if ( $AB ne "40" );
    }
   
    for my $ab ( keys %{ $ref->{ $minkey } } )
    {
        printf " $lv -> $ab, %d\n", $#$arr;
        maketree( $ref->{$minkey}{$ab},  [ sort keys %{$ref->{$minkey}{$ab}} ], $lv+1 );
    }
}

sub permute
{
    my ( $a, $b, $n, $aref ) = @_;
    my $last = $#$a;

    if ( $#$b >= ($n-1) )
    {
        push @$aref, join("", @$b);
        return;
    }

    for my $idx ( 0 .. $last )
    {
        permute( [ @$a[0 .. $idx-1, $idx+1 .. $last] ], [ @$b, $a->[$idx] ], $n, $aref );
    }
}

__END__
__C__
void bullcow(char *stra, char *strb, char *AB)
{
    int idx;
    char a = '0';
    char b = '0';

    for ( idx = 0; idx < 4; idx++ )
    {
        if ( stra[idx] == strb[idx] )
            a++;
        else
            if ( strchr(stra, strb[idx]) != 0 )
            {
                b++;
            }
    }

    AB[0] = a;
    AB[1] = b;
}[/code][b][list]
[*]结果
[/list][/b]

[quote]Times: 26408, average: 5.239683
1, 1
2, 7
3, 70
4, 647
5, 2400
6, 1811
7, 103
8, 1[/quote]

查看完整版本: Bulls and Cows 猜数字游戏 搜索树生成算法