@ -1,11 +1,12 @@
#!/usr/bin/env perl #!/usr/bin/env perl
package chess_gui ; package chess_gui ;
use Dancer2 ; use Dancer2 ;
use Dancer2::Plugin::Ajax ; #use Dancer2::Plugin::Ajax ;
use Dancer2::Session::Memcached ; # Let's use the database for session storage for now. #use Dancer2::Session::Memcached;
use Template ; use Template ;
use DBI ; use DBI ;
use DBD::Pg ; use DBD::Pg ;
#use HTTP::Cookies;
use strict ; use strict ;
use warnings ; use warnings ;
#use warnings FATAL => qw(uninitialized); #use warnings FATAL => qw(uninitialized);
@ -54,8 +55,11 @@ my $sth3 = $dbh->prepare(q/INSERT INTO black (b0, b1, k0, n0, n1, p0, p1, p2, p3
my $ sth5 = $ dbh - > prepare ( q/INSERT INTO context (bid, wid, bprio, wprio) VALUES (?, ?, ?, ?)/ ) ; my $ sth5 = $ dbh - > prepare ( q/INSERT INTO context (bid, wid, bprio, wprio) VALUES (?, ?, ?, ?)/ ) ;
my $ sth6 = $ 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 = ?/ ) ; my $ sth6 = $ 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 = ?/ ) ;
my $ sth7 = $ 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 = ?/ ) ; my $ sth7 = $ 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 = ?/ ) ;
my $ sth8 = $ dbh - > prepare ( q/SELECT black.b0, black.b1, black.k0, black.n0, black.n1, black.p0, black.p1, black.p2, black.p3, black.p4, black.p5, black.p6, black.p7, black.q0, black.r0, black.r1, white.b0, white.b1, white.k0, white.n0, white.n1, white.p0, white.p1, white.p2, white.p3, white.p4, white.p5, white.p6, white.p7, white.q0, white.r0, white.r1 FROM black, white WHERE (black.id, white.id) IN (SELECT bid, wid FROM sessions WHERE session = ?)/ ) ; #my $sth8 = $dbh->prepare(q/SELECT black.b0, black.b1, black.k0, black.n0, black.n1, black.p0, black.p1, black.p2, black.p3, black.p4, black.p5, black.p6, black.p7, black.q0, black.r0, black.r1, white.b0, white.b1, white.k0, white.n0, white.n1, white.p0, white.p1, white.p2, white.p3, white.p4, white.p5, white.p6, white.p7, white.q0, white.r0, white.r1 FROM black, white WHERE (black.id, white.id) IN (SELECT bid, wid FROM sessions WHERE session = ?)/);
my $ sth9 = $ dbh - > prepare ( q/INSERT INTO sessions (session, bid, wid) VALUES ($1, $2, $3) ON CONFLICT ON CONSTRAINT sessions_pkey DO UPDATE SET (bid, wid) = ($2, $3)/ ) ; my $ sth8 = $ dbh - > prepare ( q/SELECT b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1 FROM white WHERE id = ?/ ) ;
my $ sth9 = $ dbh - > prepare ( q/SELECT b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1 FROM black WHERE id = ?/ ) ;
my $ sth10 = $ dbh - > prepare ( q/INSERT INTO sessions (session, bid, wid) VALUES ($1, $2, $3) ON CONFLICT ON CONSTRAINT sessions_pkey DO UPDATE SET (session, bid, wid) = ($1, $2, $3)/ ) ;
my $ sth11 = $ dbh - > prepare ( q/SELECT bid, wid FROM sessions WHERE session = ?/ ) ;
my ( @ tree , @ what_i_did , % prop , @ keys , @ pplayer , % tmpalg , % tmpalg2 , % tmpalg3 , % tmpalg4 , $ players , @ not_player , $ smaleer , % pval ) ; my ( @ tree , @ what_i_did , % prop , @ keys , @ pplayer , % tmpalg , % tmpalg2 , % tmpalg3 , % tmpalg4 , $ players , @ not_player , $ smaleer , % pval ) ;
@ not_player [ 0 , 1 ] = ( 1 , 0 ) ; @ not_player [ 0 , 1 ] = ( 1 , 0 ) ;
my @ player = reverse @ not_player ; my @ player = reverse @ not_player ;
@ -69,6 +73,7 @@ my $action_limit = 100;
my $ loop_limit = 6 ; my $ loop_limit = 6 ;
my @ 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]. my @ 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].
my @ default_iboard ; my @ default_iboard ;
my @ session_iboard ;
sub INTERRUPT { sub INTERRUPT {
$ sth1 - > finish ( ) ; $ sth1 - > finish ( ) ;
$ sth2 - > finish ( ) ; $ sth2 - > finish ( ) ;
@ -78,6 +83,8 @@ sub INTERRUPT {
$ sth7 - > finish ( ) ; $ sth7 - > finish ( ) ;
$ sth8 - > finish ( ) ; $ sth8 - > finish ( ) ;
$ sth9 - > finish ( ) ; $ sth9 - > finish ( ) ;
$ sth10 - > finish ( ) ;
$ sth11 - > finish ( ) ;
$ dbh - > disconnect ; $ dbh - > disconnect ;
exit 0 ; exit 0 ;
} }
@ -108,13 +115,19 @@ sub PRETTY_CALC { # Calculate total piece value (for post-game). It used to prin
} }
sub INIT_BOARD { sub INIT_BOARD {
my ( % h0 , % h1 ) ;
if ( $# _ != - 1 ) {
#print $_[0]{'b0'}, "\n";
map { if ( defined ( $ _ [ 0 ] { $ _ } ) ) { $ h0 { $ _ [ 0 ] { $ _ } } = join '' , ( 0 , $ _ ) } } keys % { $ _ [ 0 ] } ;
map { if ( defined ( $ _ [ 1 ] { $ _ } ) ) { $ h1 { $ _ [ 1 ] { $ _ } } = join '' , ( 1 , $ _ ) } } keys % { $ _ [ 1 ] } ;
}
foreach ( 0 .. 63 ) { # Initialize chess positions piece worth (%p${player}val). foreach ( 0 .. 63 ) { # Initialize chess positions piece worth (%p${player}val).
my ( $ x , $ y , $ player ) ; my ( $ x , $ y , $ player ) ;
# $_ = sprintf("%.1o",$_/10); # (This) sprintf doesn't support octal floats. # $_ = sprintf("%.1o",$_/10); # (This) sprintf doesn't support octal floats.
$ _ = sprintf ( "%.1f" , sprintf ( "%o" , $ _ ) / 10 ) ; $ _ = sprintf ( "%.1f" , sprintf ( "%o" , $ _ ) / 10 ) ;
$ x = int ( $ _ ) ; $ x = int ( $ _ ) ;
$ y = $ _ * 10 % 10 ; # 0.x % 1 = 0 $ y = $ _ * 10 % 10 ; # 0.x % 1 = 0
# if ($#_ == -1) { if ( $# _ == - 1 ) {
if ( $ y < 2 ) { # White, hereafter called player 0. if ( $ y < 2 ) { # White, hereafter called player 0.
$ player = 0 ; $ player = 0 ;
} elsif ( $ y > 5 ) { # Black, hereafter called player 1. } elsif ( $ y > 5 ) { # Black, hereafter called player 1.
@ -142,10 +155,11 @@ sub INIT_BOARD {
push @ { $ prop { $ _ } } , ( $ player , 'b' , $ x % 2 ) ; push @ { $ prop { $ _ } } , ( $ player , 'b' , $ x % 2 ) ;
$ pval { join '' , @ { $ prop { $ _ } } } = 0.01 ; $ pval { join '' , @ { $ prop { $ _ } } } = 0.01 ;
} }
# } else { # Restore a previous state.
# }
if ( exists ( $ prop { $ _ } ) ) { $ default_iboard [ $ y ] [ $ x ] = join '' , @ { $ prop { $ _ } } } if ( exists ( $ prop { $ _ } ) ) { $ default_iboard [ $ y ] [ $ x ] = join '' , @ { $ prop { $ _ } } }
} else { # Restore a previous state (from a session).
$ session_iboard [ $ y ] [ $ x ] = $ h0 { $ _ } // $ h1 { $ _ } // $ _ ;
}
} }
$ players = 1 ; # Could do something with this if it weren't for @not_player... $ players = 1 ; # Could do something with this if it weren't for @not_player...
} }
@ -168,7 +182,7 @@ sub MOVEMENT_TREE { # Assume relative movement to support abritrary depth (0 < $
my $ ditet = $ sth1 - > fetchall_arrayref ( ) ; my $ ditet = $ sth1 - > fetchall_arrayref ( ) ;
if ( $#$ ditet != - 1 and defined ( $ { @$ ditet [ 0 ] } [ 2 / ( $ player + 1 ) + 1 ] ) ) { if ( $#$ ditet != - 1 and defined ( $ { @$ ditet [ 0 ] } [ 2 / ( $ player + 1 ) + 1 ] ) ) {
{ no warnings ; $ tmpalg { join ',' , @ keys } = $ { @$ ditet [ 0 ] } [ 2 / ( $ player + 1 ) + 1 ] } ; { no warnings ; $ tmpalg { join ',' , @ keys } = $ { @$ ditet [ 0 ] } [ 2 / ( $ player + 1 ) + 1 ] } ;
if ( $ player == $ user_mode and ( join '' , @ { $ prop { $ asrc } } ) eq $ _ [ 7 ] and $ _ [ 8 ] eq $ tree [ $ i ] { $ asrc } [ $ c ] || $ _ [ 8 ] eq ( join '' , $ prop { $ tree [ $ i ] { $ asrc } [ $ c ] } ) ) { $ tmpalg { join ',' , @ keys } = 'Inf' ; $ sth9 - > execute ( $ _ [ 9 ] , $ { @$ ditet [ 0 ] } [ 0 ] , $ { @$ ditet [ 0 ] } [ 1 ] ) } if ( $ player == $ user_mode and defined ( $ prop { $ asrc } ) and ( join '' , @ { $ prop { $ asrc } } ) eq $ _ [ 7 ] and ( $ _ [ 8 ] eq $ tree [ $ i ] { $ asrc } [ $ c ] or ( defined ( $ prop { $ tree [ $ i ] { $ asrc } [ $ c ] } ) and $ _ [ 8 ] eq ( join '' , $ prop { $ tree [ $ i ] { $ asrc } [ $ c ] } ) ) ) ) { $ tmpalg { join ',' , @ keys } = 'Inf' ; $ sth10 - > execute ( $ _ [ 9 ] , $ { @$ ditet [ 0 ] } [ 0 ] , $ { @$ ditet [ 0 ] } [ 1 ] ) }
$ keys [ $ i_al ] = $ asrc ; $ keys [ $ i_al ] = $ asrc ;
pop @ { $ tree [ $ i ] { $ asrc } } ; pop @ { $ tree [ $ i ] { $ asrc } } ;
} else { } else {
@ -432,7 +446,8 @@ $sth5->execute($bid, $wid, undef, $tmpalg{$selection});
$ sth5 - > execute ( $ bid , $ wid , $ tmpalg { $ selection } , undef ) ; $ sth5 - > execute ( $ bid , $ wid , $ tmpalg { $ selection } , undef ) ;
} }
if ( $ player == $ user_mode and ( join '' , @ asrc ) eq $ _ [ 7 ] and $ _ [ 8 ] eq $ adest || $ _ [ 8 ] eq ( join '' , @ adest ) ) { $ tmpalg { $ selection } = 'Inf' ; $ sth9 - > execute ( $ _ [ 9 ] , $ bid , $ wid ) } # if ($player == $user_mode and (join '', @asrc) eq $_[7] and ($_[8] eq $adest or $_[8] eq (join '', @adest))) {$tmpalg{$selection} = 'Inf'; $sth9->execute($_[9], $bid, $wid)}
if ( $ player == $ user_mode and $# asrc != - 1 and ( join '' , @ asrc ) eq $ _ [ 7 ] and ( $ _ [ 8 ] eq $ adest or $ _ [ 8 ] eq ( join '' , @ adest ) ) ) { $ tmpalg { $ selection } = 'Inf' ; $ sth10 - > execute ( $ _ [ 9 ] , $ bid , $ wid ) }
$ keys [ $ i_al ] = $ asrc ; $ keys [ $ i_al ] = $ asrc ;
} }
} }
@ -702,7 +717,8 @@ $user_mode = 0;
$ prio = $ val ; $ prio = $ val ;
} }
} }
if ( $ player == $ user_mode && $ prio != 'Inf' ) { # Invalid user input.
if ( $ player == $ user_mode and $ prio != 'Inf' ) { # Invalid user input.
$ player_turn - - ; $ player_turn - - ;
# push @{$diff{$player}{'warn'}} = 'Reverting an invalid set.'; # push @{$diff{$player}{'warn'}} = 'Reverting an invalid set.';
undef $ diff { $ pplayer [ $ not_player [ $ player ] ] } ; undef $ diff { $ pplayer [ $ not_player [ $ player ] ] } ;
@ -817,6 +833,10 @@ $user_mode = 0;
& POSTCHESS_CALC ( & PRETTY_CALC ( 0 , $ player ) , 1 ) ; & POSTCHESS_CALC ( & PRETTY_CALC ( 0 , $ player ) , 1 ) ;
# return; # return;
} }
if ( $ player != $ user_mode ) { $ keys [ $ c ] = $ adest ; $ sth6 - > execute ( @ keys [ 0 .. 15 ] ) ; my @ wid = $ sth6 - > fetchrow_array ( ) ; $ sth7 - > execute ( @ keys [ 16 .. 31 ] ) ; my @ bid = $ sth7 - > fetchrow_array ( ) ; print $ bid [ 0 ] , ' ' , $# bid , ' ' , $# wid , ' ' , $ wid [ 0 ] , "\n" ; $ sth10 - > execute ( $ sessid , $ bid [ 0 ] , $ wid [ 0 ] ) ; $ keys [ $ c ] = $ asrc }
# if ($player == 0) {
# $keys[$c]
# }
for ( my $ c = 0 ; $# keys >= $ c ; $ c + + ) { $ keys [ $ c ] = undef and last if defined ( $ keys [ $ c ] ) and $ keys [ $ c ] == $ adest } for ( my $ c = 0 ; $# keys >= $ c ; $ c + + ) { $ keys [ $ c ] = undef and last if defined ( $ keys [ $ c ] ) and $ keys [ $ c ] == $ adest }
@ { $ prop { $ adest } } = @ { $ piece } ; @ { $ prop { $ adest } } = @ { $ piece } ;
$ keys [ $ c ] = $ adest ; $ keys [ $ c ] = $ adest ;
@ -824,6 +844,7 @@ $user_mode = 0;
} else { } else {
@ { $ prop { $ adest } } = @ { $ piece } ; @ { $ prop { $ adest } } = @ { $ piece } ;
$ keys [ $ c ] = $ adest ; $ keys [ $ c ] = $ adest ;
if ( $ player != $ user_mode ) { $ sth6 - > execute ( @ keys [ 0 .. 15 ] ) ; my @ wid = $ sth6 - > fetchrow_array ( ) ; $ sth7 - > execute ( @ keys [ 16 .. 31 ] ) ; my @ bid = $ sth7 - > fetchrow_array ( ) ; $ sth10 - > execute ( $ sessid , $ bid [ 0 ] , $ wid [ 0 ] ) }
undef $ prop { $ asrc } ; undef $ prop { $ asrc } ;
} }
# &PRETTY_CALC; # &PRETTY_CALC;
@ -838,6 +859,8 @@ $user_mode = 0;
& INIT_BOARD ; & INIT_BOARD ;
& INIT_KEYS ; & INIT_KEYS ;
#my $jar = HTTP::Cookies->new;
get '/move/:src/:dst' = > sub { get '/move/:src/:dst' = > sub {
if ( session ( 'init' ) ) { if ( session ( 'init' ) ) {
my % diff = & PROGRAM ( route_parameters - > get ( 'src' ) , route_parameters - > get ( 'dst' ) , session ) ; # Includes player input. my % diff = & PROGRAM ( route_parameters - > get ( 'src' ) , route_parameters - > get ( 'dst' ) , session ) ; # Includes player input.
@ -846,22 +869,36 @@ if (session('init')) {
} ; } ;
any [ 'get' , 'post' ] = > '/' = > sub { any [ 'get' , 'post' ] = > '/' = > sub {
my $ session = session ; # TODO: I only want %{session}{'id'}.
$ session = % { $ session } { 'id' } ;
$ sth11 - > execute ( $ session ) ;
print $ session , "\n" ;
my @ sth11 = $ sth11 - > fetchrow_array ( ) ;
print $# sth11 , "\n" ;
if ( session ( 'init' ) or defined ( $ sth11 [ 0 ] ) ) {
if ( request - > method ( ) eq "POST" ) { if ( request - > method ( ) eq "POST" ) {
if ( session ( 'init' ) ) {
if ( length ( body_parameters - > get ( 'id' ) ) == 1 and body_parameters - > get ( 'id' ) =~ m/\A[1-7]\z/ ) { # Sanitize user input (even if in a session). if ( length ( body_parameters - > get ( 'id' ) ) == 1 and body_parameters - > get ( 'id' ) =~ m/\A[1-7]\z/ ) { # Sanitize user input (even if in a session).
my $ setting_id = body_parameters - > get ( 'id' ) ; my $ setting_id = body_parameters - > get ( 'id' ) ;
redirect '/aaaaa' ; redirect '/aaaaa' ;
} }
}
} else {
if ( session ( 'init' ) ) {
$ sth8 - > execute ( session ( 'id' ) ) ;
template 'index' = > { board = > $ sth8 - > fetchall_arrayref ( ) } ;
} else { } else {
# $sth8->execute($session); # TODO: The column name in the hash is without the table name, even if the SQL query includes table names for tables with the same column name (resulting in silently overwritten keys). Workaround with multiple queries.
$ sth8 - > execute ( $ sth11 [ 1 ] ) ;
$ sth9 - > execute ( $ sth11 [ 0 ] ) ;
# &INIT_BOARD($sth8->fetchrow_hashref(), $sth9->fetchrow_hashref()); # Complains about attempted modification of RO-value when a piece takes an enemy piece.
my $ r1 = $ sth8 - > fetchrow_hashref ( ) ;
my $ r2 = $ sth9 - > fetchrow_hashref ( ) ;
& INIT_BOARD ( $ r1 , $ r2 ) ;
# $sth8->execute($session);
# my $hr = $sth8->fetchrow_hashref();
# &INIT_BOARD($hr);
template 'index' = > { board = > \ @ session_iboard } ;
}
} elsif ( request - > method ( ) eq "GET" ) {
session 'init' = > true ; session 'init' = > true ;
#$jar->add_cookie_header($session);
template 'index' = > { board = > \ @ default_iboard } ; template 'index' = > { board = > \ @ default_iboard } ;
} }
}
} ; } ;
true ; #true ;
Roy
2 years ago