Roy
/
chess-gui
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add config/sessions/init to database model, and rewrite search tree.

Browse Source
feature/Make_modular
Roy 3 months ago
parent c4e6b2b774
commit 3a4a583484
1 changed files with 719 additions and 0 deletions
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Show Stats Download Patch File Download Diff File
  1. 719
      chess_gui/lib/chess_core.pm

719
chess_gui/lib/chess_core.pm
Unescape View File

@ -0,0 +1,719 @@
#!/usr/bin/env perl
package chess_core;
use DBI;
use DBD::Pg;
use strict;
use warnings;
# Self-learning, chess game written in Perl. Its main goal is to be smarter than its creator by utilizing generic (minimax) but decently fast algorithms (depends on the configurable depth of the chess board tree and your processor) with a push in the right direction by self-learning.
# The self-learning aspect involves iterating through as much as reasonably possible chess possibilities from the default chess setup. One fixed AI iterates through all valid moves, while the other AI reacts accordingly. The outcome is stored in a database for next matches.
# (C) Roy van Lunsen.
our $VERSION = '2.0';
my ($dbaname, $dbauser, $dbh, %dbhs, @direction, @keys, @not_player, @player, %ppiece, @pplayer, %prop, %pval, @px, %pxr, %SIG, $smaleer, @split_piece_column_names);
my %CHOICE = (
'p' => \&PAWN,
'n' => \&KNIGHT,
'b' => \&BISHOP,
'r' => \&ROOK,
'q' => \&QUEEN,
'k' => \&KING
);
my %OPERATING_MODE = ( # Of player.
'NPC' => \&MOVEMENT_TREE,
'PC' => \&PC
);
my %OUTPUT_FORMAT = (
'plain' => \&PRINT_OVERVIEW, # TODO: Refresh.
# 'plain_color' => \&PRETTY_PRINT_OVERVIEW # TODO: ANSI color codes.
'none' => sub {} # Equivalent to verbosity quiet.
);
my %LOOP_LIMIT_ACTION = ( # Behaviour on loop detection.
'evaluate-terminate' => \&POSTCHESS_CALC,
# 'evaluate-undo' => \&PAWN, # TODO: subroutine.
'continue' => \&PASS
);
my %STATUS_ACTION = (
'0' => \&PASS, # Normal flow.
'1' => sub {
my $action = shift @_; # TODO: Param. currently ignored.
\&POSTCHESS_CALC; # On checkmate.
},
'2' => sub {
my $action = shift @_;
$LOOP_LIMIT_ACTION{${$action}{'loop_limit_action'}}->(&PRETTY_CALC(0, $_[0]), @_[1..$#_]);
}
);
my %STATUS_MODIFIER = (
'1' => \&CHECKMATE_CALC,
'2' => \&STALEMATE_CALC
);
my %RECORD = (
'0' => \&PASS,
# '1' => \&RECORD # TODO: Support.
);
$SIG{'INT'} = 'INTERRUPT';
sub PASS {} # Do nothing.
sub INIT_SUPPOSITION {
$dbaname = 'chessd'; # See ./chess.sql.
$dbauser = 'postgres';
$dbh = DBI->connect("dbi:Pg:dbname=$dbaname", $dbauser, '', {PrintError => 1, RaiseError => 1, AutoCommit => 1}) or die $?;
%dbhs = (
'get-context' => $dbh->prepare(q/SELECT bid, wid, black_prio, white_prio FROM context WHERE (bid, wid) IN (SELECT black.id, white.id FROM black, white WHERE white.b0 = ? and white.b1 = ? and white.k0 = ? and white.n0 = ? and white.n1 = ? and white.p0 = ? and white.p1 = ? and white.p2 = ? and white.p3 = ? and white.p4 = ? and white.p5 = ? and white.p6 = ? and white.p7 = ? and white.q0 = ? and white.r0 = ? and white.r1 = ? and black.b0 = ? and black.b1 = ? and black.k0 = ? and black.n0 = ? and black.n1 = ? and black.p0 = ? and black.p1 = ? and black.p2 = ? and black.p3 = ? and black.p4 = ? and black.p5 = ? and black.p6 = ? and black.p7 = ? and black.q0 = ? and black.r0 = ? and black.r1 = ?)/),
'set-context-white' => $dbh->prepare(q/INSERT INTO context (bid, wid, white_prio) VALUES ($1, $2, $3) ON CONFLICT ON CONSTRAINT context_pkey DO UPDATE SET white_prio = $3/),
'set-context-black' => $dbh->prepare(q/INSERT INTO context (bid, wid, black_prio) VALUES ($1, $2, $3) ON CONFLICT ON CONSTRAINT context_pkey DO UPDATE SET black_prio = $3/),
'update-context-white' => $dbh->prepare(q/UPDATE context SET white_prio = ? FROM black, white WHERE black.id = bid and white.id = wid and white.b0 = ? and white.b1 = ? and white.k0 = ? and white.n0 = ? and white.n1 = ? and white.p0 = ? and white.p1 = ? and white.p2 = ? and white.p3 = ? and white.p4 = ? and white.p5 = ? and white.p6 = ? and white.p7 = ? and white.q0 = ? and white.r0 = ? and white.r1 = ? and black.b0 = ? and black.b1 = ? and black.k0 = ? and black.n0 = ? and black.n1 = ? and black.p0 = ? and black.p1 = ? and black.p2 = ? and black.p3 = ? and black.p4 = ? and black.p5 = ? and black.p6 = ? and black.p7 = ? and black.q0 = ? and black.r0 = ? and black.r1 = ?/),
'update-context-black' => $dbh->prepare(q/UPDATE context SET black_prio = ? FROM black, white WHERE black.id = bid and white.id = wid and white.b0 = ? and white.b1 = ? and white.k0 = ? and white.n0 = ? and white.n1 = ? and white.p0 = ? and white.p1 = ? and white.p2 = ? and white.p3 = ? and white.p4 = ? and white.p5 = ? and white.p6 = ? and white.p7 = ? and white.q0 = ? and white.r0 = ? and white.r1 = ? and black.b0 = ? and black.b1 = ? and black.k0 = ? and black.n0 = ? and black.n1 = ? and black.p0 = ? and black.p1 = ? and black.p2 = ? and black.p3 = ? and black.p4 = ? and black.p5 = ? and black.p6 = ? and black.p7 = ? and black.q0 = ? and black.r0 = ? and black.r1 = ?/),
'get-white-id' => $dbh->prepare(q/SELECT id FROM white WHERE b0 = ? and b1 = ? and k0 = ? and n0 = ? and n1 = ? and p0 = ? and p1 = ? and p2 = ? and p3 = ? and p4 = ? and p5 = ? and p6 = ? and p7 = ? and q0 = ? and r0 = ? and r1 = ?/),
'get-white-row' => $dbh->prepare(q/SELECT b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1 FROM white WHERE id = ?/),
'get-black-id' => $dbh->prepare(q/SELECT id FROM black WHERE b0 = ? and b1 = ? and k0 = ? and n0 = ? and n1 = ? and p0 = ? and p1 = ? and p2 = ? and p3 = ? and p4 = ? and p5 = ? and p6 = ? and p7 = ? and q0 = ? and r0 = ? and r1 = ?/),
'get-black-row' => $dbh->prepare(q/SELECT b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1 FROM black WHERE id = ?/),
'set-white' => $dbh->prepare(q/INSERT INTO white (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/),
'set-black' => $dbh->prepare(q/INSERT INTO black (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/),
'get-session' => $dbh->prepare(q/SELECT session, bid, wid, move FROM sessions WHERE session = ?/),
'set-session' => $dbh->prepare(q/INSERT INTO sessions (session, bid, wid, move) VALUES ($1, $2, $3, $4) ON CONFLICT ON CONSTRAINT sessions_pkey DO UPDATE SET (bid, wid, move) = ($2, $3, $4)/),
'new-session' => $dbh->prepare(q/SELECT gen_random_uuid()/),
'get-config' => $dbh->prepare(q/SELECT black, white, total_move_limit, output_format, tree_depth_black, tree_depth_white, loop_limit, loop_limit_action, record FROM configurations WHERE session = ?/),
'set-config' => $dbh->prepare(q/INSERT INTO configurations (session) values ($1)/),
'update-config' => $dbh->prepare(q/UPDATE configurations SET (black, white, total_move_limit, output_format, tree_depth_black, tree_depth_white, loop_limit, loop_limit_action, record) = (?, ?, ?, ?, ?, ?, ?, ?, ?) WHERE configurations.session = ?/)
);
@direction = qw/1 1 1 -1 -1 -1 -1 1 0 1 0 -1 1 0 -1 0 0.5 2 0.5 -2 -0.5 -2 -0.5 2/; # Diagonal direction modifiers: $direction[0..7]. Straight direction modifiers: $direction[8..15]. Knight direction modifiers: $direction[0..7,16..23].
@not_player[0, 1] = (1, 0);
@player = reverse @not_player;
@ppiece{qw/b k n p q r/} = qw/bishop king knight pawn queen rook/;
@pplayer[0, 1] = qw/white black/;
@px = ('A'..'H');
@pxr{'A'..'H'} = (0..7);
@split_piece_column_names = qw/b 0 b 1 k 0 n 0 n 1 p 0 p 1 p 2 p 3 p 4 p 5 p 6 p 7 q 0 r 0 r 1/;
}
sub INTERRUPT {
foreach my $key (keys %dbhs) {
$dbhs{$key}->finish();
}
$dbh->disconnect;
exit 0;
}
sub STALEMATE_CALC { # Stalemate. Various causes.
my ($pval, $current_player, $called_player) = @_;
if ($current_player == 0) {
return -1; # Try out other selections (if the next game is similar) for benefit of black. # TODO: Remove in production.
} elsif ($called_player == 0) {
return $pval * -1;
} else {
return $pval;
}
}
sub CHECKMATE_CALC { # Won: add king value; Lost: subtract king value.
my ($pval, $current_player, $called_player) = @_;
if ($current_player == $called_player) {
return $pval + $pval{$current_player.'k0'};
} else {
return $pval * -1 - $pval{$current_player.'k0'};
}
}
sub PC { # Player character. Contrast with NPC.
my ($player, $tree, $tmpalg, $max_tree_depth, $source, $destination) = @_;
my ($xrc, $yrc) = split //, $source;
$source = join '.', $pxr{$xrc}, ($yrc-1);
($xrc, $yrc) = split //, $destination;
$destination = join '.', $pxr{$xrc}, ($yrc-1);
&MOVEMENT_TREE($player, 1, undef, undef, undef, undef, undef, $source, $destination); # TODO: Depth needs to be always at least 2 for king.
if (defined(${${$tree}[0]}{$source}) and scalar(grep $_ eq $destination, @{${$tree}[0]}{$source}) >= 0) { # Ensure the PC is not sacrificing its king (by undefing these movements beforehand).
for (my $j = 0; $#keys >= $j; $j++) {
if ($keys[$j] eq $source) {
my $old_source = $keys[$j];
$keys[$j] = $source;
${$tmpalg}[0]{join ',', @keys}[1] = 'Inf';
$keys[$j] = $old_source;
last;
}
}
}
# $dbhs{'set-session'}->execute($player, ${$context}{'bid'}, ${$context}{'wid'});
}
sub LOOP_CHECK {
my ($configuration, $player, $pseudoinfinite_loop_check, $evenval1, $unevenval1, $evenval2, $unevenval2) = @_;
for (my $c = 0; $#{$pseudoinfinite_loop_check} >= $c; $c++) {
if ($c > 1) {
if ($c > 3) {
if ($c % 2 == 0) {
if ($c % 4 == 0) {
next if $evenval1 eq ${$pseudoinfinite_loop_check}[$c];
last;
} elsif (($c+1) % 4 == 0) {
next if $unevenval1 eq ${$pseudoinfinite_loop_check}[$c];
last;
} elsif (($c+2) % 4 == 0) {
next if $evenval2 eq ${$pseudoinfinite_loop_check}[$c];
last;
} elsif (($c+3) % 4 == 0) {
next if $unevenval2 eq ${$pseudoinfinite_loop_check}[$c];
last;
}
}
} elsif ($c % 2 == 0) {
$evenval2 = ${$pseudoinfinite_loop_check}[$c];
next;
} else {
$unevenval2 = ${$pseudoinfinite_loop_check}[$c];
next;
}
} elsif ($c % 2 == 0) {
$evenval1 = ${$pseudoinfinite_loop_check}[$c];
next;
} else {
$unevenval1 = ${$pseudoinfinite_loop_check}[$c];
next;
}
return 1;
}
return 0;
}
sub PRETTY_CALC { # Calculate total piece value (for post-game). It used to print the chess board.
my ($pval, $player) = @_;
foreach my $secondc (0..7) {
foreach my $firstc (0..7) {
my $coordinate = $firstc.'.'.(7-$secondc);
if (defined($prop{$coordinate})) {
my $p = join '', @{$prop{$coordinate}};
if ($prop{$coordinate}[0] == $player) {
$pval += $pval{$p};
} else {
$pval -= $pval{$p};
}
}
}
}
return ($pval, $player);
}
sub PRINT_OVERVIEW { # Chess output implementation for terminal.
my ($pplayer, $diff) = @_;
print $pplayer, ' turn ', ${$diff}{$pplayer}{'no_set'}+1, ':', "\n";
print ${$diff}{$pplayer}{'src_pc'}, ' moves from ', ${$diff}{$pplayer}{'src_xy'}, ' to ', ${$diff}{$pplayer}{'dst_xy'};
print ' and takes ', ${$diff}{$pplayer}{'dst_pc'} if exists(${$diff}{$pplayer}{'dst_pc'});
print "\n";
print 'mv#', ${$diff}{$pplayer}{'mv_nu'}, '/', ${$diff}{$pplayer}{'mv_no'}, '; confidence: ', ${$diff}{$pplayer}{'mv_val'}, "\n";
foreach my $secondc (0..7) {
print "\n";
foreach my $firstc (0..7) {
my $coordinate = $firstc.'.'.(7-$secondc);
if (defined($prop{$coordinate})) {
my $p = join '', @{$prop{$coordinate}};
printf '%-8s', $p;
} else {
printf '%-8s', $px[$firstc].(8-$secondc);
}
}
print "\n";
}
print "\n";
if (${$diff}{$pplayer}{'status'} == 1) {
print $pplayer, ' wins!', "\n";
&INTERRUPT();
}
}
sub INIT_BOARD {
foreach (0..63) { # Initialize chess positions piece worth (%p${player}val).
my ($x, $y, $player);
$_ = sprintf("%.1f", sprintf("%o", $_)/10);
$x = int($_);
$y = $_ * 10 % 10; # 0.x % 1 = 0
if ($y < 2) { # White, hereafter called player 0.
$player = 0;
} elsif ($y > 5) { # Black, hereafter called player 1.
$player = 1;
} else {
next;
}
if ($y*2 % 10 == 2) { # Pawn.
push @{$prop{$_}}, ($player, 'p', $x);
$pval{join '', @{$prop{$_}}} = 0.001;
} elsif ($x % 7 == 0) { # Rook.
push @{$prop{$_}}, ($player, 'r', $x / 7);
$pval{join '', @{$prop{$_}}} = 0.01;
} elsif ($x % 5 == 1) { # Knight.
push @{$prop{$_}}, ($player, 'n', ($x-1) / 5);
$pval{join '', @{$prop{$_}}} = 0.01;
} elsif ($x == 3) { # Queen.
push @{$prop{$_}}, ($player, 'q', 0);
$pval{join '', @{$prop{$_}}} = 0.1;
} elsif ($x == 4) { # King.
push @{$prop{$_}}, ($player, 'k', 0);
$pval{join '', @{$prop{$_}}} = '1'; # Instead of skipping if the allied king is taken in a branch, we can assign infinite value to the king. That doesn't work well with premature calculations, though, so we assign it (more than) the combined value of all other allied pieces at this point.
} else { # Bishop.
push @{$prop{$_}}, ($player, 'b', $x % 2);
$pval{join '', @{$prop{$_}}} = 0.01;
}
}
&INIT_KEYS();
}
sub INIT_KEYS { # For sorted lookup of piece source.
@keys = sort { (join '', @{$prop{$a}}) cmp (join '', @{$prop{$b}}) } keys %prop; # Sort hash keys by piece properties (values). Will complain if not used at the start of the match.
}
sub MOVEMENT_TREE { # Assume relative movement to support abritrary depth (0 < $max_depth < Inf).
my ($player, $tree, $tmpalg, $max_depth, $current_depth, $dpval_ref, $tmpalg_ref) = (@_[0..3], $_[4] // -2, $_[5], $_[6] // undef); # Support for travelling to different tree depths every player turn (could be used to create, e.g., adaptive AI).
$current_depth+=2;
my $current_allyp_i = $_[7] // $player*16-1;
ALLY_SOURCE: foreach my $asrc (&KEYS($player)) {
# my $dpval = $dpval_ref // 0; # Default piece value.
my $dpval = 0; # Default piece value.
$current_allyp_i++;
next unless defined($asrc);
@{${$tree}[$current_depth]{$asrc}} = $CHOICE{$prop{$asrc}[1]}->($asrc);
for (my $c = $#{${$tree}[$current_depth]{$asrc}}; $c >= 1; $c--) { # This should make the subroutine multiple times faster if there's no previous untravelled branch.
$keys[$current_allyp_i] = ${$tree}[$current_depth]{$asrc}[$c];
$dbhs{'get-context'}->execute(@keys);
my $context = $dbhs{'get-context'}->fetchrow_hashref();
if (defined($context) and defined(%$context{$pplayer[$player].'_prio'})) {
my $tmpkey = join ',', @keys;
push @{${$tmpalg}[$current_depth]{$tmpkey}}, ($tmpalg_ref // $tmpkey, ${$context}{$pplayer[$player].'_prio'}); # Add reference to previous move (and stored movement priority for $tmpkey).
$keys[$current_allyp_i] = $asrc;
pop @{${$tree}[$current_depth]{$asrc}}; # Already calculated all destinations for this movement.
} else {
$keys[$current_allyp_i] = $asrc;
last;
}
}
ALLY_DESTINATION: foreach my $adest (@{${$tree}[$current_depth]{$asrc}}) {
my ($selection, @asrc, @adest);
if ($adest != $asrc) {
$keys[$current_allyp_i] = $adest;
{no warnings; $selection = join ',', @keys}; # CSV.
$dbhs{'get-context'}->execute(@keys);
my $context = $dbhs{'get-context'}->fetchrow_hashref();
if (defined($context) and defined(%$context{$pplayer[$player].'_prio'})) { # Already calculated the context for this $adest (and since @keys has a fixed order, for this $piece): Skip to save precious time.
push @{${$tmpalg}[$current_depth]{$selection}}, ($tmpalg_ref // $selection, ${$context}{$pplayer[$player].'_prio'});
$keys[$current_allyp_i] = $asrc; # Undo the (reverse-lookup) move.
next ALLY_DESTINATION; # Already stored this move in the DB, so there's no reason to recalculate our priorities now.
} else {
push @{${$tmpalg}[$current_depth]{$selection}}, ($tmpalg_ref // $selection, 0);
}
if (defined($prop{$adest})) {
@adest = @{$prop{$adest}};
${$tmpalg}[$current_depth]{$selection}[1] += $pval{join '', @adest}; # Prioritize high-value enemy pieces.
}
@{$prop{$adest}} = @asrc = @{$prop{$asrc}};
undef $prop{$asrc};
} elsif ($#{${$tree}[$current_depth]{$asrc}} <= 0) { # If the allied piece can't move we don't consider what the enemy can do to it in their next turn with the allied piece itself because that depends on the movement of another allied piece.
next;
}
my $current_enemyp_i = $_[8] // 16-$player*16-1;
ENEMY_SOURCE: foreach my $esrc (my @esrc_keys = &KEYS($not_player[$player])) {
last if $max_depth == 1+$current_depth;
$current_enemyp_i++;
next unless defined($esrc);
@{${$tree}[1+$current_depth]{$esrc}} = $CHOICE{$prop{$esrc}[1]}->($esrc);
ENEMY_DESTINATION: foreach my $edest (@{${$tree}[1+$current_depth]{$esrc}}) {
my (@esrc, @edest);
if ($#{${$tree}[1+$current_depth]{$esrc}} > 0) {
$keys[$current_enemyp_i] = $edest;
if (defined($prop{$edest})) { # Enemy dest. is defined (can either mean enemy moves to [ally || itself and ally does not move to itself]).
@edest = @{$prop{$edest}};
if ($edest != $esrc) {
if (defined($selection)) { # Equivalent to $asrc != $adest.
if ($prop{$esrc}[1] eq 'b' || $prop{$esrc}[1] eq 'q' || $prop{$esrc}[1] eq 'r') { # Blockable "ranged" enemy pieces. Encourage other pieces to protect each other, depending on piece value.
my $dd = sprintf '%.0f', (sqrt(($edest - $esrc)**2)*10); # dd = (defensive) dx. Rounded because of inaccurate floats.
if ($esrc > $edest) {
$smaleer = $edest*10;
} else {
$smaleer = $esrc*10;
}
if ($dd % 11 == 0) { # NE or SW movement
for (my $bdki = $smaleer+11; $dd >= $bdki; $bdki += 11) {
${$tmpalg}[$current_depth]{$selection}[1] += $pval{join '', @edest} - $pval{join '', @asrc} if (int(join '', split(/\./, $adest)) == $bdki);
}
} elsif ($dd % 9 == 0) { # NW or SE movement
for (my $bdki = $smaleer+9; $dd >= $bdki; $bdki += 9) {
${$tmpalg}[$current_depth]{$selection}[1] += $pval{join '', @edest} - $pval{join '', @asrc} if (int(join '', split(/\./, $adest)) == $bdki);
}
} elsif ($dd % 10 == 0) { # E or W movement
for (my $bdki = $smaleer+10; $dd >= $bdki; $bdki += 10) {
${$tmpalg}[$current_depth]{$selection}[1] += $pval{join '', @edest} - $pval{join '', @asrc} if (int(join '', split(/\./, $adest)) == $bdki);
}
} elsif ($dd % 1 == 0) { # N or S movement
for (my $bdki = $smaleer+1; $dd >= $bdki; $bdki += 1) {
${$tmpalg}[$current_depth]{$selection}[1] += $pval{join '', @edest} - $pval{join '', @asrc} if (int(join '', split(/\./, $adest)) == $bdki);
}
}
}
${$tmpalg}[$current_depth]{$selection}[1] -= $pval{join '', @edest}; # ... Not to an(other) enemy destination.
} else {
$dpval = $pval{join '', @edest} if $dpval < $pval{join '', @edest}; # Encourage all movement of this piece to wherever, but (see above)...
}
}
}
@{$prop{$edest}} = @esrc = @{$prop{$esrc}};
undef $prop{$esrc};
} else {
next;
}
if ($max_depth > 2+$current_depth and defined($selection)) {
# my $x = join ',', @keys,"\n";
# my $xx = $current_allyp_i;
&MOVEMENT_TREE($player, $tree, $tmpalg, $max_depth, $current_depth, $dpval_ref, \@{${$tmpalg}[$current_depth]{$selection}});
# my $y = join ',', @keys,"\n";
# my $yy = $current_allyp_i;
# if ($x ne $y or $xx != $yy) {print $x, "\n", $y, "\n", $xx, "\n", $yy; die 22;}
}
if (@esrc) {
if (@edest) {
@{$prop{$edest}} = @edest;
} else {
undef $prop{$edest};
}
@{$prop{$esrc}} = @esrc;
}
$keys[$current_enemyp_i] = $esrc;
}
}
if (@asrc) {
if (@adest) {
@{$prop{$adest}} = @adest;
} else {
undef $prop{$adest};
}
@{$prop{$asrc}} = @asrc;
}
if (defined($selection)) {
# my ($bid, $wid);
# ${$tmpalg}[$current_depth]{$selection}[1] += $dpval - $tmpalg2{$selection} + $tmpalg3{$selection} - $tmpalg4{$selection};
${$tmpalg}[$current_depth]{$selection}[1] += $dpval;
# $dbhs{'get-white-id'}->execute(@keys[0..15]);
# my @wid = $dbhs{'get-white-id'}->fetchrow_array();
# if ($#wid == -1) {
# $dbhs{'set-white'}->execute(@keys[0..15]);
# $wid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_wid'});
# } else {
# $wid = $wid[0];
# }
# $dbhs{'get-black-id'}->execute(@keys[16..31]);
# my @bid = $dbhs{'get-black-id'}->fetchrow_array();
# if ($#bid == -1) {
# $dbhs{'set-black'}->execute(@keys[16..31]);
# $bid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_bid'});
# } else {
# $bid = $bid[0];
# }
#
# $dbhs{'set-context-'.$pplayer[$player]}->execute($bid, $wid, ${$tmpalg}[$current_depth]{$selection}[1]);
$keys[$current_allyp_i] = $asrc;
}
}
}
}
sub QUEEN {
my ($pos, @out_int, $movx, $movy) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
foreach my $mod (0..7) { # There are eight directions from the position of the queen.
my $xmod = $direction[$mod*2];
my $ymod = $direction[$mod*2+1];
foreach (1..7) { # Movement (delta) cannot be lower than 1 and higher than 7.
$movx = $xpos-$_*$xmod;
$movy = $ypos-$_*$ymod;
my $mov = $movx.'.'.$movy;
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
last;
} elsif (7 >= $movx >= 0 and 7 >= $movy >= 0) {
push @out_int, $mov;
} else {
last;
}
}
}
return @out_int;
}
sub KING {
my ($pos, @out_int, $movx, $movy) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
foreach my $mod (0..7) { # Eight potential directions.
my $xmod = $direction[$mod*2];
my $ymod = $direction[$mod*2+1];
$movx = $xpos-1*$xmod;
$movy = $ypos-1*$ymod;
my $mov = $movx.'.'.$movy;
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
} elsif (7 >= $movx >= 0 and 7 >= $movy >= 0) {
push @out_int, $mov;
}
}
return @out_int;
}
sub PAWN {
my ($pos, @out_int, $mov, $mod) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
if ($prop{$_[0]}[0] == 0) {
$mod = -1;
} else {
$mod = 1;
}
if ($ypos == 1 or $ypos == 6) {
foreach (1..2) {
$mov = $xpos.'.'.($ypos-$_*$mod);
if (defined($prop{$mov})) {
last;
} elsif (0 <= $ypos-$_*$mod <= 7) {
push @out_int, $mov;
}
}
} else {
$mov = $xpos.'.'.($ypos-1*$mod);
unless ($prop{$mov}) {
push @out_int, $mov if 0 <= $ypos-1*$mod <= 7;
}
}
$mov = ($xpos-1*$mod).'.'.($ypos-1*$mod);
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
}
$mov = ($xpos+1*$mod).'.'.($ypos-1*$mod);
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
}
return @out_int;
}
sub BISHOP {
my ($pos, @out_int, $movx, $movy) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
foreach my $mod (0..3) { # Four potential diagonal directions.
my $xmod = $direction[$mod*2];
my $ymod = $direction[$mod*2+1];
foreach (1..7) {
$movx = $xpos-$_*$xmod;
$movy = $ypos-$_*$ymod;
my $mov = $movx.'.'.$movy;
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
last;
} elsif (7 >= $movx >= 0 and 7 >= $movy >= 0) {
push @out_int, $mov;
} else {
last;
}
}
}
return @out_int;
}
sub ROOK {
my ($pos, @out_int, $movx, $movy) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
foreach my $mod (4..7) { # Four potential straight directions.
my $xmod = $direction[$mod*2];
my $ymod = $direction[$mod*2+1];
foreach (1..7) {
$movx = $xpos-$_*$xmod;
$movy = $ypos-$_*$ymod;
my $mov = $movx.'.'.$movy;
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
last;
} elsif (7 >= $movx >= 0 and 7 >= $movy >= 0) {
push @out_int, $mov;
} else {
last;
}
}
}
return @out_int;
}
sub KNIGHT {
my ($pos, @out_int, $movx, $movy) = $_[0];
my ($xpos, $ypos) = split /\./, ($out_int[0] = $pos);
foreach my $mod (0..3,8..11) { # Eight potential directions.
my $xmod = $direction[$mod*2];
my $ymod = $direction[$mod*2+1];
$movx = $xpos-2*$xmod;
$movy = $ypos-1*$ymod;
my $mov = $movx.'.'.$movy;
if (defined($prop{$mov})) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
} elsif (7 >= $movx >= 0 and 7 >= $movy >= 0) {
push @out_int, $mov;
}
}
return @out_int;
}
sub KEYS { # Arguments: ($player).
my ($player, @tree_keys) = $_[0];
# map {if (defined($_)) {push @tree_keys, $_ if $prop{$_}} else {push @tree_keys, undef}} @keys[($player*16)..($player*16+15)];
map {if (defined($_) and defined($prop{$_})) {push @tree_keys, $_} else {push @tree_keys, undef}} @keys[($player*16)..($player*16+15)];
return @tree_keys;
}
sub CLEANUP_POSTGAME {
undef %prop;
$#keys = -1;
}
sub POSTCHESS_CALC {
my ($pval, $called_player, $reason, $what_i_did) = @_;
foreach my $current_player (@player) {
my $mpval = $STATUS_MODIFIER{$reason}->($pval, $current_player, $called_player);
foreach my $match_keys (keys %{${$what_i_did}[$current_player]}) {
${$what_i_did}[$current_player]{$match_keys} += $mpval;
my @keys = map {$_ eq '' ? $_ = undef : $_} split /,/, $match_keys;
$dbhs{'update-context-'.$pplayer[$current_player]}->execute(${$what_i_did}[$current_player]{$match_keys}, @keys);
}
}
}
sub TMPALG_LOOP { # Follow references until the end (i.e., start of allied @tree) of this recursive data structure. Assume deeper in the tree means less movement weight.
my ($ref, $combined_priority, $modifier) = (@_); # Input example: ${$tmpalg[$i]{$selection}}[0]
$combined_priority += ${$ref}[1]*$modifier;
if (ref ${$ref}[0] eq 'ARRAY') {
&TMPALG_LOOP(\@{${$ref}[0]}, $combined_priority, $modifier*10);
} else {
return (${$ref}[0], $combined_priority);
}
}
sub CHESS_PROGRAM { # Main routine.
my ($session, %session, $source, $destination, @what_i_did, @pseudoinfinite_loop_check, $configuration, %configuration) = @_;
&INIT_SUPPOSITION();
$dbhs{'get-config'}->execute($session);
$configuration = $dbhs{'get-config'}->fetchrow_hashref(); # RO ref.
if (!defined($configuration)) { # Store a new session with default initialization values.
&INIT_BOARD();
$dbhs{'new-session'}->execute();
$session = $dbhs{'new-session'}->fetchrow_array();
$dbhs{'set-session'}->execute($session, 1, 1, 1);
$dbhs{'get-session'}->execute($session);
$session = $dbhs{'get-session'}->fetchrow_hashref();
$dbhs{'set-config'}->execute(${$session}{'session'});
$dbhs{'get-config'}->execute(${$session}{'session'});
$configuration = $dbhs{'get-config'}->fetchrow_hashref();
} else { # Restore an existing session.
$dbhs{'get-session'}->execute($session);
$session = $dbhs{'get-session'}->fetchrow_hashref();
$dbhs{'get-white-row'}->execute(${$session}{'wid'});
$dbhs{'get-black-row'}->execute(${$session}{'bid'});
&CLEANUP_POSTGAME();
{my $x = 0; map {$keys[$x+16] = $_; if (defined($_)) {push @{$prop{$_}}, (1, @split_piece_column_names[($x*2)..($x*2+1)])}; $x++} @{$dbhs{'get-black-row'}->fetchrow_arrayref}};
{my $x = 0; map {if (!defined($_) or exists($prop{$_})) {$keys[$x] = undef} else {$keys[$x] = $_; push @{$prop{$_}}, (0, @split_piece_column_names[($x*2)..($x*2+1)])}; $x++} @{$dbhs{'get-white-row'}->fetchrow_arrayref}}; # Not applying it correctly with @keys and %prop modifications after $dbhs{'set-session'}.
}
%session = %{$session}; # Needs RW access.
MATCH: for (;($session{'move'}) < ${$configuration}{'total_move_limit'}; $session{'move'}+=2) { # Even using uneven numbers will grant black the same amount of moves as white.
MOVE: foreach my $player (@player) { # TODO: Let both players utilize each other's tree starting at $selection. Used correctly, this should improve performance.
my ($max_tree_depth, $max_priority, @tree, @tmpalg, @collective, %diff) = (${$configuration}{'tree_depth_'.$pplayer[$player]}, -Inf); # Player configuration tree_depth includes enemy branches.
$diff{$pplayer[$player]}{'status'} = 0;
$diff{$pplayer[$player]}{'no_set'} = $session{'move'}/2-0.5;
$OPERATING_MODE{${$configuration}{$pplayer[$player]}}->($player, \@tree, \@tmpalg, $max_tree_depth, $source, $destination);
foreach my $max_depth_selection (keys %{$tmpalg[$#tmpalg]}) { # For every $depth/2 (i.e., each ally branch in @tree).
my ($min_depth_selection, $priority) = &TMPALG_LOOP(\@{$tmpalg[$#tmpalg]{$max_depth_selection}}, 0, 10**(-$#tmpalg+1)); # Loop through a recursive data structure with an recursive algorithm. TODO: Modifier multiplication steps need to be higher than maximum movement count.
if ($priority >= $max_priority) {
print $priority, ' ', ${$tmpalg[$#tmpalg]{$max_depth_selection}}[1], ' ', ${$tmpalg[0]{$min_depth_selection}}[1],"\n";
while ($#collective >= 0 and $priority > ${$collective[0]}[1]) { # FIFO queue.
shift @collective; # TODO: Regardless of what the enemy does, for this piece, what is the maximum gain? And the minimum loss? Combine these values into a priority.
}
$max_priority = $priority;
# print $min_depth_selection,"\n";
push @{$collective[$#collective+1]}, ($min_depth_selection, $priority);
}
}
my $no_selections = $#collective+1; # Number of valid moves with the same $max_priority.
my $ice = int(rand($no_selections));
my ($selection, $prio) = (@{$collective[$ice]}[0..1]);
my ($bid, $wid);
$diff{$pplayer[$player]}{'mv_no'} = $no_selections;
$diff{$pplayer[$player]}{'mv_nu'} = $ice+1;
$diff{$pplayer[$player]}{'mv_val'} = $prio;
if (${$configuration}{$pplayer[$player]} eq 'PC') {
if ($prio != 'Inf') { # Invalid user input.
redo MOVE;
}
} else {
if (($session{'move'}+$player) % (${$configuration}{'loop_limit'}+1) == 0) {
if (&LOOP_CHECK($configuration, $player, \@pseudoinfinite_loop_check)) { # When player 0 is iterating through all chess possibilities in training mode, stop & do the usual decrement when both players have been doing the same four-turn loop at least three times successively. If we don't stop the program here but do stop the four-turn loop, player 1 might prioritize creating loops when breaking the loop would be a final blow for player 0. TODO: Alternatively, we might revert back here to some previous state...
$diff{$pplayer[$player]}{'status'} = 2;
}
$#pseudoinfinite_loop_check = -1;
$pseudoinfinite_loop_check[0] = $selection;
}
if ($prio != 'Inf') {
$what_i_did[$player]{$selection} = $prio;
}
}
my $c = 0;
my $adest;
my @selection = split('[,]', $selection);
foreach my $position (@selection) {
if (defined($keys[$c]) and $keys[$c] != $position) {
$adest = $position;
last;
}
$c++;
}
my $asrc = $keys[$c];
my $piece = $prop{$asrc};
# print $asrc, ' ', $c, "\n" if !defined($piece);
my ($sxc, $syc) = split('[.]', $asrc);
my ($dxc, $dyc) = split('[.]', $adest);
$diff{$pplayer[$player]}{'src_xy'} = join '', $px[$sxc], ($syc+1);
$diff{$pplayer[$player]}{'dst_xy'} = join '', $px[$dxc], ($dyc+1);
$diff{$pplayer[$player]}{'src_pc'} = join '', @{$piece};
if (defined($prop{$adest})) {
$diff{$pplayer[$player]}{'dst_pc'} = (join '', @{$prop{$adest}});
if ($prop{$adest}[1] eq 'k') {
$diff{$pplayer[$player]}{'status'} = 1; # Status 1 overrides status 2, etc..
} else {
for (my $c = 0; $#keys >= $c; $c++){$keys[$c] = undef and last if defined($keys[$c]) and $keys[$c] == $adest}
@{$prop{$adest}} = @{$piece};
$keys[$c] = $adest;
undef $prop{$asrc};
}
} else {
@{$prop{$adest}} = @{$piece};
$keys[$c] = $adest;
undef $prop{$asrc};
}
$OUTPUT_FORMAT{${$configuration}{'output_format'}}->($pplayer[$player], \%diff);
$STATUS_ACTION{$diff{$pplayer[$player]}{'status'}}->(\%configuration, $player, $diff{$pplayer[$player]}{'status'}, \@what_i_did); # Scalar params.
$RECORD{${$configuration}{'record'}}->(\%session, $bid, $wid);
}
}
# return %diff
}
&CHESS_PROGRAM();
&INTERRUPT();
Write Preview
Loading…
Cancel
Save