Dancer2 contents. Some things are yet to be modified (removed). Subject to change.

main
Roy 2 years ago
parent 9758a8ab73
commit ba89c92bb3
  1. 0
      chess_gui/.dancer
  2. 24
      chess_gui/MANIFEST
  3. 17
      chess_gui/MANIFEST.SKIP
  4. 26
      chess_gui/Makefile.PL
  5. 45
      chess_gui/bin/app.psgi
  6. 71
      chess_gui/config.yml
  7. 34
      chess_gui/cpanfile
  8. 20
      chess_gui/environments/development.yml
  9. 13
      chess_gui/environments/production.yml
  10. 867
      chess_gui/lib/chess_gui.pm
  11. 18
      chess_gui/public/404.html
  12. 18
      chess_gui/public/500.html
  13. 86
      chess_gui/public/css/error.css
  14. 63
      chess_gui/public/css/index.css
  15. 16
      chess_gui/public/dispatch.cgi
  16. 18
      chess_gui/public/dispatch.fcgi
  17. 1
      chess_gui/public/i/0.0.png
  18. 1
      chess_gui/public/i/0.1.png
  19. 1
      chess_gui/public/i/0.2.png
  20. 1
      chess_gui/public/i/0.3.png
  21. 1
      chess_gui/public/i/0.4.png
  22. 1
      chess_gui/public/i/0.5.png
  23. 1
      chess_gui/public/i/0.6.png
  24. 1
      chess_gui/public/i/0.7.png
  25. 1
      chess_gui/public/i/0b0.png
  26. 1
      chess_gui/public/i/0b1.png
  27. 1
      chess_gui/public/i/0k0.png
  28. 1
      chess_gui/public/i/0n0.png
  29. 1
      chess_gui/public/i/0n1.png
  30. 1
      chess_gui/public/i/0p0.png
  31. 1
      chess_gui/public/i/0p1.png
  32. 1
      chess_gui/public/i/0p2.png
  33. 1
      chess_gui/public/i/0p3.png
  34. 1
      chess_gui/public/i/0p4.png
  35. 1
      chess_gui/public/i/0p5.png
  36. 1
      chess_gui/public/i/0p6.png
  37. 1
      chess_gui/public/i/0p7.png
  38. 1
      chess_gui/public/i/0q0.png
  39. 1
      chess_gui/public/i/0r0.png
  40. 1
      chess_gui/public/i/0r1.png
  41. 1
      chess_gui/public/i/1.0.png
  42. 1
      chess_gui/public/i/1.1.png
  43. 1
      chess_gui/public/i/1.2.png
  44. 1
      chess_gui/public/i/1.3.png
  45. 1
      chess_gui/public/i/1.4.png
  46. 1
      chess_gui/public/i/1.5.png
  47. 1
      chess_gui/public/i/1.6.png
  48. 1
      chess_gui/public/i/1.7.png
  49. 1
      chess_gui/public/i/1b0.png
  50. 1
      chess_gui/public/i/1b1.png
  51. 1
      chess_gui/public/i/1k0.png
  52. 1
      chess_gui/public/i/1n0.png
  53. 1
      chess_gui/public/i/1n1.png
  54. 1
      chess_gui/public/i/1p0.png
  55. 1
      chess_gui/public/i/1p1.png
  56. 1
      chess_gui/public/i/1p2.png
  57. 1
      chess_gui/public/i/1p3.png
  58. 1
      chess_gui/public/i/1p4.png
  59. 1
      chess_gui/public/i/1p5.png
  60. 1
      chess_gui/public/i/1p6.png
  61. 1
      chess_gui/public/i/1p7.png
  62. 1
      chess_gui/public/i/1q0.png
  63. 1
      chess_gui/public/i/1r0.png
  64. 1
      chess_gui/public/i/1r1.png
  65. 1
      chess_gui/public/i/2.0.png
  66. 1
      chess_gui/public/i/2.1.png
  67. 1
      chess_gui/public/i/2.2.png
  68. 1
      chess_gui/public/i/2.3.png
  69. 1
      chess_gui/public/i/2.4.png
  70. 1
      chess_gui/public/i/2.5.png
  71. 1
      chess_gui/public/i/2.6.png
  72. 1
      chess_gui/public/i/2.7.png
  73. 1
      chess_gui/public/i/3.0.png
  74. 1
      chess_gui/public/i/3.1.png
  75. 1
      chess_gui/public/i/3.2.png
  76. 1
      chess_gui/public/i/3.3.png
  77. 1
      chess_gui/public/i/3.4.png
  78. 1
      chess_gui/public/i/3.5.png
  79. 1
      chess_gui/public/i/3.6.png
  80. 1
      chess_gui/public/i/3.7.png
  81. 1
      chess_gui/public/i/4.0.png
  82. 1
      chess_gui/public/i/4.1.png
  83. 1
      chess_gui/public/i/4.2.png
  84. 1
      chess_gui/public/i/4.3.png
  85. 1
      chess_gui/public/i/4.4.png
  86. 1
      chess_gui/public/i/4.5.png
  87. 1
      chess_gui/public/i/4.6.png
  88. 1
      chess_gui/public/i/4.7.png
  89. 1
      chess_gui/public/i/5.0.png
  90. 1
      chess_gui/public/i/5.1.png
  91. 1
      chess_gui/public/i/5.2.png
  92. 1
      chess_gui/public/i/5.3.png
  93. 1
      chess_gui/public/i/5.4.png
  94. 1
      chess_gui/public/i/5.5.png
  95. 1
      chess_gui/public/i/5.6.png
  96. 1
      chess_gui/public/i/5.7.png
  97. 1
      chess_gui/public/i/6.0.png
  98. 1
      chess_gui/public/i/6.1.png
  99. 1
      chess_gui/public/i/6.2.png
  100. 1
      chess_gui/public/i/6.3.png
  101. Some files were not shown because too many files have changed in this diff Show More

@ -0,0 +1,24 @@
MANIFEST
MANIFEST.SKIP
Makefile.PL
cpanfile
config.yml
.dancer
bin/app.psgi
t/001_base.t
t/002_index_route.t
views/index.tt
public/dispatch.fcgi
public/favicon.ico
public/500.html
public/dispatch.cgi
public/404.html
lib/chess_gui.pm
environments/development.yml
environments/production.yml
views/layouts/main.tt
public/javascripts/jquery.js
public/css/style.css
public/css/error.css
public/images/perldancer-bg.jpg
public/images/perldancer.jpg

@ -0,0 +1,17 @@
^\.git\/
maint
^tags$
.last_cover_stats
Makefile$
^blib
^pm_to_blib
^.*.bak
^.*.old
^t.*sessions
^cover_db
^.*\.log
^.*\.swp$
MYMETA.*
^.gitignore
^.svn\/
^chess_gui-

@ -0,0 +1,26 @@
use strict;
use warnings;
use ExtUtils::MakeMaker;
# Normalize version strings like 6.30_02 to 6.3002,
# so that we can do numerical comparisons on it.
my $eumm_version = $ExtUtils::MakeMaker::VERSION;
$eumm_version =~ s/_//;
WriteMakefile(
NAME => 'chess_gui',
AUTHOR => q{YOUR NAME <youremail@example.com>},
VERSION_FROM => 'lib/chess_gui.pm lib/chess_gui.pm',
ABSTRACT => 'YOUR APPLICATION ABSTRACT',
($eumm_version >= 6.3001
? ('LICENSE'=> 'perl')
: ()),
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
'YAML' => 0,
'Dancer2' => 0.400000,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'chess_gui-*' },
);

@ -0,0 +1,45 @@
#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
# use this block if you don't need middleware, and only have a single target Dancer app to run here
use chess_gui;
chess_gui->to_app;
=begin comment
# use this block if you want to include middleware such as Plack::Middleware::Deflater
use chess_gui;
use Plack::Builder;
builder {
enable 'Deflater';
chess_gui->to_app;
}
=end comment
=cut
=begin comment
# use this block if you want to mount several applications on different path
use chess_gui;
use chess_gui_admin;
use Plack::Builder;
builder {
mount '/' => chess_gui->to_app;
mount '/admin' => chess_gui_admin->to_app;
}
=end comment
=cut

@ -0,0 +1,71 @@
# This is the main configuration file of your Dancer2 app
# env-related settings should go to environments/$env.yml
# all the settings in this file will be loaded at Dancer's startup.
# === Basic configuration ===
# Your application's name
appname: "chess_gui"
# The default layout to use for your application (located in
# views/layouts/main.tt)
#layout: "main"
# when the charset is set to UTF-8 Dancer2 will handle for you
# all the magic of encoding and decoding. You should not care
# about unicode within your app when this setting is set (recommended).
charset: "UTF-8"
# === Engines ===
#
# NOTE: All the engine configurations need to be under a single "engines:"
# key. If you uncomment engine configurations below, make sure to delete
# all "engines:" lines except the first. Otherwise, only the last
# "engines:" block will take effect.
# template engine
# simple: default and very basic template engine
# template_toolkit: TT
#template: "simple"
plugins:
Ajax:
content_type: 'application/json'
template: "template_toolkit"
# engines:
# template:
# template_toolkit:
# # Note: start_tag and end_tag are regexes
# start_tag: '<%'
# end_tag: '%>'
# session engine
#
# Simple: in-memory session store - Dancer2::Session::Simple
# YAML: session stored in YAML files - Dancer2::Session::YAML
#
# Check out metacpan for other session storage options:
# https://metacpan.org/search?q=Dancer2%3A%3ASession&search_type=modules
#
# Default value for 'cookie_name' is 'dancer.session'. If you run multiple
# Dancer apps on the same host then you will need to make sure 'cookie_name'
# is different for each app.
#
engines:
session:
# Memcached:
# memcached_servers:
# - /var/sock/memcached
# fatal_cluster_unreachable: 0
Simple:
cookie_name: testapp.session
#engines:
# session:
# YAML:
# cookie_name: eshop.session
# is_secure: 1
# is_http_only: 1

@ -0,0 +1,34 @@
requires "Dancer2" => "0.400000";
recommends "YAML" => "0";
recommends "URL::Encode::XS" => "0";
recommends "CGI::Deurl::XS" => "0";
recommends "CBOR::XS" => "0";
recommends "YAML::XS" => "0";
recommends "Class::XSAccessor" => "0";
recommends "Crypt::URandom" => "0";
recommends "HTTP::XSCookies" => "0";
recommends "HTTP::XSHeaders" => "0";
recommends "Math::Random::ISAAC::XS" => "0";
recommends "MooX::TypeTiny" => "0";
recommends "Type::Tiny::XS" => "0";
feature 'accelerate', 'Accelerate Dancer2 app performance with XS modules' => sub {
requires "URL::Encode::XS" => "0";
requires "CGI::Deurl::XS" => "0";
requires "YAML::XS" => "0";
requires "Class::XSAccessor" => "0";
requires "Cpanel::JSON::XS" => "0";
requires "Crypt::URandom" => "0";
requires "HTTP::XSCookies" => "0";
requires "HTTP::XSHeaders" => "0";
requires "Math::Random::ISAAC::XS" => "0";
requires "MooX::TypeTiny" => "0";
requires "Type::Tiny::XS" => "0";
};
on "test" => sub {
requires "Test::More" => "0";
requires "HTTP::Request::Common" => "0";
};

@ -0,0 +1,20 @@
# configuration file for development environment
# the logger engine to use
# console: log messages to STDOUT (your console where you started the
# application server)
# file: log message to a file in log/
logger: "console"
# the log level for this environment
# core is the lowest, it shows Dancer2's core log messages as well as yours
# (debug, info, warning and error)
log: "core"
# should Dancer2 show a stacktrace when an 5xx error is caught?
# if set to yes, public/500.html will be ignored and either
# views/500.tt, 'error_template' template, or a default error template will be used.
show_errors: 1
# print the banner
startup_info: 1

@ -0,0 +1,13 @@
# configuration file for production environment
# only log warning and error messsages
log: "warning"
# log message to a file in logs/
logger: "file"
# hide errors
show_errors: 0
# disable server tokens in production environments
no_server_tokens: 1

@ -0,0 +1,867 @@
#!/usr/bin/env perl
package chess_gui;
use Dancer2;
use Dancer2::Plugin::Ajax;
use Dancer2::Session::Memcached; # Let's use the database for session storage for now.
use Template;
use DBI;
use DBD::Pg;
use strict;
use warnings;
#use warnings FATAL => qw(uninitialized);
# Self-learning, console-based chess game written in Perl.
# The self-learning aspect involves iterating through all chess layouts 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 later retrieval.
# (C) Roy van Lunsen.
our $VERSION = '37.0';
#sub USAGE_MSG {
# print 'Usage:', "\n";
# print '`', $0, ' auto`: Run the chess program non-interactively.', "\n";
# print '`', $0, ' manual`: Run the chess program interactively (i.e., you can control one side).', "\n";
# exit 1;
#}
#my $user_mode;
#if ($#ARGV < 0) {
# &USAGE_MSG;
#} elsif ('manual' eq $ARGV[0]) {
# $user_mode = undef;
#} elsif ('auto' eq $ARGV[0]) {
# $user_mode = -1;
#} else {
# &USAGE_MSG;
#}
my $dbname = 'chessd'; # See ./chess.sql.
my $username = 'postgres';
my $dbh = DBI->connect("dbi:Pg:dbname=$dbname", $username, '', {PrintError => 1, RaiseError => 1, AutoCommit => 1}) or die $?;
#my $dbh = DBI->connect("dbi:Pg:dbname=$dbname", $username, '', {PrintError => 0, RaiseError => 0, AutoCommit => 1}) or die $?;
#my $sth1 = $dbh->prepare(q/SELECT black.id, white.id, black.prio, white.prio FROM black, white WHERE black.id = white.id 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 = ?/); #TODO: There should be a better way to do this...
#my $sth0 = $dbh->prepare(q/SELECT bw_id, prio FROM white, context 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 white.b0 = ? and context.b1 = ? and context.k0 = ? and context.n0 = ? and context.n1 = ? and context.p0 = ? and context.p1 = ? and context.p2 = ? and context.p3 = ? and context.p4 = ? and context.p5 = ? and context.p6 = ? and context.p7 = ? and context.q0 = ? and context.r0 = ? and context.r1 = ?/);
#my $sth1 = $dbh->prepare(q/SELECT bw_id, prio FROM black, context WHERE 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 = ? and black.b0 = ? and context.b1 = ? and context.k0 = ? and context.n0 = ? and context.n1 = ? and context.p0 = ? and context.p1 = ? and context.p2 = ? and context.p3 = ? and context.p4 = ? and context.p5 = ? and context.p6 = ? and context.p7 = ? and context.q0 = ? and context.r0 = ? and context.r1 = ?/);
#my $sth1 = $dbh->prepare(q/SELECT black.id, white.id, bprio, wprio FROM black, white, context 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 = ?/); #TODO: There should be a better way to do this...
#my $sth1 = $dbh->prepare(q/SELECT black.id, white.id FROM black, white WHERE (black.id, white.id) IN (SELECT bid, wid FROM context) 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 = ?/);
my $sth1 = $dbh->prepare(q/SELECT bid, wid, bprio, wprio 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 = ?)/);
#my $sth2 = $dbh->prepare(q/INSERT INTO white (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1, prio) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
#my $sth3 = $dbh->prepare(q/INSERT INTO black (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1, prio) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
#my $sth2 = $dbh->prepare(q/INSERT INTO white (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
#my $sth3 = $dbh->prepare(q/INSERT INTO black (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
#my $sth4 = $dbh->prepare(q/INSERT INTO context (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1, prio) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
my $sth2 = $dbh->prepare(q/INSERT INTO white (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)/);
my $sth3 = $dbh->prepare(q/INSERT INTO black (b0, b1, k0, n0, n1, p0, p1, p2, p3, p4, p5, p6, p7, q0, r0, r1) 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 $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 $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 (@tree, @what_i_did, %prop, @keys, @pplayer, %tmpalg, %tmpalg2, %tmpalg3, %tmpalg4, $players, @not_player, $smaleer, %pval);
@not_player[0, 1] = (1, 0);
my @player = reverse @not_player;
@pplayer[0, 1] = qw/w b/;
my @pseudoinfinite_loop_check;
my $user_mode;
my $player;
my $player_turn = 0;
my $counter;
my $action_limit = 100;
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 @default_iboard;
sub INTERRUPT {
$sth1->finish();
$sth2->finish();
$sth3->finish();
$sth5->finish();
$sth6->finish();
$sth7->finish();
$sth8->finish();
$sth9->finish();
$dbh->disconnect;
exit 0;
}
$SIG{'INT'} = 'INTERRUPT';
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) {
# print "\n";
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};
}
# printf '%-8s', $p;
} else {
# printf '%-8s', $coordinate;
}
}
# print "\n";
}
return ($pval, $player);
}
sub INIT_BOARD {
foreach (0..63) { # Initialize chess positions piece worth (%p${player}val).
my ($x, $y, $player);
# $_ = sprintf("%.1o",$_/10); # (This) sprintf doesn't support octal floats.
$_ = sprintf("%.1f", sprintf("%o", $_)/10);
$x = int($_);
$y = $_ * 10 % 10; # 0.x % 1 = 0
# if ($#_ == -1) {
if ($y < 2) { # White, hereafter called player 0.
$player = 0;
} elsif ($y > 5) { # Black, hereafter called player 1.
$player = 1;
} else {
$default_iboard[$y][$x] = $_;
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;
}
# } else { # Restore a previous state.
# }
if (exists($prop{$_})) {$default_iboard[$y][$x] = join '', @{$prop{$_}}}
}
$players = 1; # Could do something with this if it weren't for @not_player...
}
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 < $depth < Inf).
my ($player, $depth, $i_al, $i) = (@_[0, 1], $_[5] // $_[0]*16-1, $_[2] // -4); # Support for travelling to different tree depths every player turn (could be used to create, e.g., adaptive AI).
$i += 4;
ALLY_SOURCE: foreach my $asrc (&KEYS($player)) {
my $dpval = $_[3] // 0; # Default piece value.
$i_al++;
next unless defined($asrc);
@{$tree[$i]{$asrc}} = &CHOICE($asrc); # The tree depth is $i+1.
for (my $c = $#{$tree[$i]{$asrc}}; $c >= 1; $c--) { # This should make the subroutine multiple times faster if there's no previous untravelled branch.
$keys[$i_al] = $tree[$i]{$asrc}[$c];
$sth1->execute(@keys);
my $ditet = $sth1->fetchall_arrayref();
if ($#$ditet != -1 and defined(${@$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])}
$keys[$i_al] = $asrc;
pop @{$tree[$i]{$asrc}};
} else {
$keys[$i_al] = $asrc;
last;
}
}
ALLY_DESTINATION: foreach my $adest (@{$tree[$i]{$asrc}}) {
my ($selection, @asrc, @adest);
if ($adest != $asrc) {
$keys[$i_al] = $adest;
{no warnings; $selection = join ',', @keys}; # CSV.
$sth1->execute(@keys);
my $ditet = $sth1->fetchall_arrayref();
if ($#$ditet != -1 and defined(${@$ditet[0]}[2/($player+1)+1])) { # Already calculated the context for this $adest (and since @keys has a fixed order, for this $piece): Skip to save precious time.
$tmpalg{$selection} = ${@$ditet[0]}[2/($player+1)+1];
$keys[$i_al] = $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 {print 'false', "\n"}
if ($prop{$adest}) {
@adest = @{$prop{$adest}};
$tmpalg{$selection} += $pval{join '', @adest}; # Prioritize high-value enemy pieces.
}
@{$prop{$adest}} = @asrc = @{$prop{$asrc}};
undef $prop{$asrc};
($tmpalg2{$selection}, $tmpalg3{$selection}, $tmpalg4{$selection}) = (0, 0, 0);
} elsif ($#{$tree[$i]{$asrc}} <= 0) {
# my $sth = $dbh->prepare("SELECT priority FROM main_table WHERE selection = 'join ',', @keys'");
# $sth->execute();
# my $priority = $sth->fetchall_arrayref();
# if (@$priority[0]) { # $asrc exists as part of @keys in the DB (as opposed to $adest).
# $keys[$i_al] = $asrc; # Undo the (reverse-lookup) move.
# next ALLY_SOURCE; # At this point we have stored every move (for this piece) in the DB, so there's no reason to go to the next ALLY_DESTINATION.
# }
next;
}
my $i_en = $_[6] // 16-$player*16-1;
ENEMY_SOURCE: foreach my $esrc (my @esrc_keys = &KEYS($not_player[$player])) {
last if $depth == 1+$i;
$i_en++;
next unless defined($esrc);
# if ($esrc != $adest) {
@{$tree[1+$i]{$esrc}} = &CHOICE($esrc);
# } #else {
# next;
# }
ENEMY_DESTINATION: foreach my $edest (@{$tree[1+$i]{$esrc}}) {
my (@esrc, @edest);
if ($#{$tree[1+$i]{$esrc}} > 0) {
$keys[$i_en] = $edest;
if ($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)) {
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.
# $tmpalg2{$selection} = $pval{join '', @edest} if $tmpalg2{$selection} < $pval{join '', @edest}; # Discourage movement by the value of the targeted ally.
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{$selection} += $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{$selection} += $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{$selection} += $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{$selection} += $pval{join '', @edest} - $pval{join '', @asrc} if (int(join '', split(/\./, $adest)) == $bdki);
}
}
} #else {
$tmpalg{$selection} -= $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};
# print @{$prop{$edest}}, ': ', $edest, "\n";
} else {
next;
}
ALLY_SOURCE2: foreach my $asrc2 (my @asrc2_keys = &KEYS($player)) {
last if $depth == 2+$i;
my $dpval2 = $_[4] // 0; # Default piece value.
# if ($asrc2 != $edest) {
next unless defined($asrc2);
@{$tree[2+$i]{$asrc2}} = &CHOICE($asrc2);
# } else {
# next;
# }
foreach my $adest2 (@{$tree[2+$i]{$asrc2}}) {
next if $asrc2 == $asrc; # Skip dups as a result of looping over one of the same ally piece for every other ally piece.
my (@asrc2, @adest2);
if ($adest2 != $asrc2) {
if ($prop{$adest2}) {
@adest2 = @{$prop{$adest2}};
if (defined($selection)) {
push @{$tmpalg3{$selection}}, $pval{join '', @adest2}; # For use in ENEMY_SOURCE2.
}
# print @{$prop{$adest2}}, ': ', @{$prop{$asrc2}}, ' ', $asrc2, ' -> ', $adest2, "\n";
# $tmpalg3{$edest}{$adest2}++;
# print @{$prop{$adest}}, ': ', $asrc2, ' -> ', @adest2, "\n" if (scalar keys %{$tmpalg3{$asrc2}}) >= ($#{$tree[1+$i]{$esrc}}+1); # Prioritize high-value enemy pieces.
#TODO: Can't we just make a counter and decrement tmpalg if the counter > tmpalg2?
# print $adest, ' ', $adest2, ' ', @{$prop{$adest2}}, ' ', $tmpalg2{$adest}{join '', @adest2}, '/', $#{$tree[1+$i]{$esrc}}+1, "\n" and
# $tmpalg{$selection} += $pval{join '', @adest2} if $tmpalg2{$adest}{join '', @adest2} >= ($#{$tree[1+$i]{$esrc}}+1+$#esrc_keys+$#asrc2_keys); # Prioritize high-value enemy pieces.
}
@{$prop{$adest2}} = @asrc2 = @{$prop{$asrc2}};
undef $prop{$asrc2};
# print @{$prop{$adest2}}, ': ', $adest2, "\n";
} elsif ($#{$tree[2+$i]{$asrc2}} <= 0) {
next;
}
ENEMY_SOURCE2: foreach my $esrc2 (&KEYS($not_player[$player])) {
last if $depth == 3+$i;
# if ($esrc2 != $adest2) {
next unless defined($esrc2);
$keys[$i_al] = $adest2;
@{$tree[3+$i]{$esrc2}} = &CHOICE($esrc2);
# } else {
# next;
# }
foreach my $edest2 (@{$tree[3+$i]{$esrc2}}) {
my (@esrc2, @edest2);
if ($#{$tree[3+$i]{$esrc2}} > 0) {
$keys[$i_en] = $edest2;
if ($prop{$edest2}) {
@edest2 = @{$prop{$edest2}};
push @{$tmpalg3{$selection}[-1]}, $pval{join '', @edest2};
# $tmpalg3{$selection} = 0 if $edest2 == $adest2 and $edest2 != $edest and defined($selection);
# if ($edest2 != $esrc2) {
# if ($selection) {
# if ($prop{$esrc2}[1] eq 'b' || $prop{$esrc2}[1] eq 'q' || $prop{$esrc2}[1] eq 'r') { # Blockable "ranged" enemy pieces. Encourage other pieces to protect each other, depending on piece value.
# $tmpalg4{$selection} = $pval{join '', @edest2} if $tmpalg4{$selection} < $pval{join '', @edest2}; # Discourage movement by the value of the targeted ally.
# my $dd = sprintf '%.0f', (sqrt(($edest2 - $esrc2)**2)*10); # dd = (defensive) dx. Rounded because of inaccurate floats.
# if ($esrc2 > $edest2) {
# $smaleer = $edest2*10;
# } else {
# $smaleer = $esrc2*10;
# }
# if ($dd % 11 == 0) { # NE or SW movement
# for (my $bdki = $smaleer+11; $dd >= $bdki; $bdki += 11) {
# $tmpalg3{$selection} += $pval{join '', @edest2} if (int(join '', split(/\./, $adest)) == $bdki);
# }
# } elsif ($dd % 9 == 0) { # NW or SE movement
# for (my $bdki = $smaleer+9; $dd >= $bdki; $bdki += 9) {
# $tmpalg3{$selection} += $pval{join '', @edest2} if (int(join '', split(/\./, $adest)) == $bdki);
# }
# } elsif ($dd % 10 == 0) { # E or W movement
# for (my $bdki = $smaleer+10; $dd >= $bdki; $bdki += 10) {
# $tmpalg3{$selection} += $pval{join '', @edest2} if (int(join '', split(/\./, $adest)) == $bdki);
# }
# } elsif ($dd % 1 == 0) { # N or S movement
# for (my $bdki = $smaleer+1; $dd >= $bdki; $bdki += 1) {
# $tmpalg3{$selection} += $pval{join '', @edest2} if (int(join '', split(/\./, $adest)) == $bdki);
# }
# }
# } else {
# $tmpalg3{$selection} -= $pval{join '', @edest2} + $dpval; # Not to an(other) enemy destination.
# }
# } else {
# $dpval = $pval{join '', @edest2} if $dpval < $pval{join '', @edest2}; # Encourage all movement of this piece to wherever, but (see above)...
# }
# }
}
@{$prop{$edest2}} = @esrc2 = @{$prop{$esrc2}};
undef $prop{$esrc2};
# print @{$prop{$edest2}}, ': ', $edest2, "\n";
} else {
next;
}
&MOVEMENT_TREE($player, $depth, $i, $dpval, $dpval2, $i_al, $i_en) if $depth > 4+$i; # Recursion up to $depth/4. #TODO: Make recursion give the proper amount of possibilities.
if (@esrc2) {
if (@edest2) {
@{$prop{$edest2}} = @edest2;
} else {
undef $prop{$edest2};
}
@{$prop{$esrc2}} = @esrc2;
}
$keys[$i_en] = $edest;
}
}
if (@asrc2) {
if (@adest2) {
@{$prop{$adest2}} = @adest2;
} else {
undef $prop{$adest2};
}
@{$prop{$asrc2}} = @asrc2;
}
$tmpalg{$selection} += $dpval2 if $selection;
$keys[$i_al] = $adest;
}
}
if (@esrc) {
if (@edest) {
@{$prop{$edest}} = @edest;
} else {
undef $prop{$edest};
}
@{$prop{$esrc}} = @esrc;
}
$keys[$i_en] = $esrc;
}
}
if (@asrc) {
if (@adest) {
@{$prop{$adest}} = @adest;
} else {
undef $prop{$adest};
}
@{$prop{$asrc}} = @asrc;
}
if ($selection) {
my ($bid, $wid);
$tmpalg{$selection} += $dpval - $tmpalg2{$selection} + $tmpalg3{$selection} - $tmpalg4{$selection};
$sth6->execute(@keys[0..15]);
$wid = $sth6->fetchall_arrayref();
unless ($#$wid != -1) {
$sth2->execute(@keys[0..15]);
$wid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_wid'});
} else {$wid = ${@$wid[0]}[0]}
$sth7->execute(@keys[16..31]);
$bid = $sth7->fetchall_arrayref();
unless ($#$bid != -1) {
$sth3->execute(@keys[16..31]);
$bid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_bid'});
} else {$bid = ${@$bid[0]}[0]}
if ($player == 0) {
$sth5->execute($bid, $wid, undef, $tmpalg{$selection});
} else {
#$sth7->execute(@keys[16..31]);
#my $bid = $sth7->fetchall_arrayref();
# unless ($#$bid != -1) {
#$sth3->execute(@keys[16..31]);
#$bid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_bid'});
#} else {$bid = ${@$bid[0]}[0]}
#$sth6->execute(@keys[0..15]);
#my $wid = $sth6->fetchall_arrayref();
# unless ($#$wid != -1) {
#$sth2->execute(@keys[0..15]);
#$wid = $dbh->last_insert_id(undef, undef, undef, undef, {sequence => 'seq_wid'});
#} else {$wid = ${@$wid[0]}[0]}
$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)}
$keys[$i_al] = $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 ($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 ($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 ($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 ($prop{$mov}) {
push @out_int, $mov if $prop{$mov}[0] != $prop{$_[0]}[0];
}
$mov = ($xpos+1*$mod).'.'.($ypos-1*$mod);
if ($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 ($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 ($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 ($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 CHOICE { # Strict refs compliance.
if ($prop{$_[0]}[1] eq 'p') {
&PAWN($_[0]);
} elsif ($prop{$_[0]}[1] eq 'n') {
&KNIGHT($_[0]);
} elsif ($prop{$_[0]}[1] eq 'b') {
&BISHOP($_[0]);
} elsif ($prop{$_[0]}[1] eq 'r') {
&ROOK($_[0]);
} elsif ($prop{$_[0]}[1] eq 'q') {
&QUEEN($_[0]);
} elsif ($prop{$_[0]}[1] eq 'k') {
&KING($_[0]);
} else {
die 'Invalid parameter(s): ', @_, "\n";
}
}
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];
return @tree_keys;
}
sub CLEANUP_POSTGAME {
undef %prop;
$#keys = -1;
}
sub CLEANUP_POSTTURN {
undef %tmpalg;
undef %tmpalg2;
$#tree = -1;
}
sub POSTCHESS_CALC {
my ($pval, $called_player, $reason) = @_; # Arguments: (Value of all pieces of $player - $not_player[$player], $player, reason for exiting the game (did a $player win?)).
foreach my $current_player (@player) {
my $mpval;
my $sth4 = $dbh->prepare(q/UPDATE context SET /.$pplayer[$not_player[$current_player]].q/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 = ?/);
if ($reason == 0) { # Stalemate. Various causes.
if ($current_player == 0) {
$mpval = -1; # Try out other selections (if the next game is similar) for benefit of player 1. #TODO: Remove in production.
} elsif ($called_player == 0) {
$mpval = $pval * -1;
} else {
$mpval = $pval;
}
} elsif ($reason == 1) {
if ($current_player == 0) {
if ($called_player == 0) {
$mpval = $pval;
} else {
$mpval = $pval * -1;
}
} else {
if ($called_player == 1) {
$mpval = $pval;
} else {
$mpval = $pval * -1;
}
}
}
foreach my $anothervar (keys %{$what_i_did[$current_player]}) {
$what_i_did[$current_player]{$anothervar} += $mpval;
$sth4->execute($what_i_did[$current_player]{$anothervar}, @keys);
}
}
}
sub PROGRAM {
my $sessid = $_[2]{'id'};
$user_mode = 0;
# if (!defined($user_mode)) {
# print 'Please input your side:', "\n";
# foreach (@player) {
# print $_, ': ';
# if ($_ == 0) {
# print 'white (recommended)', "\n"; # The AI has been trained for the opponent (you) making the first move. Reflect that in the selection for now.
# } elsif ($_ == 1) {
# print 'black', "\n";
# }
# }
# INPUT_LOOP: while (1) {
# chomp(my $input = <STDIN>);
# foreach my $player (@player) {
# if ($input eq $player) {
# $user_mode = $player;
# last INPUT_LOOP;
# }
# }
# print 'Invalid input', ' `', $input, '`', ".\n";
# }
# }
# MATCH: while (1) {
my %diff;
$player_turn++;
# $player = ($player_turn+1) % 2;
TURN: foreach my $player (@player) {
# @{$diff{'msg'}{'turn'}}[$player] = 'Player ' . $player . ' turn ' . $player_turn . ':';
push @{$diff{$pplayer[$player]}{'status'}}, $player_turn;
my ($depth, %key_list_by_value, $prio, $ice, @selection);
my ($dpval, $i_al) = (0, 0);
if ($player == $user_mode) { # If the player is human-controlled, we needn't more than $depth 1 (for input validation).
$depth = 1;
&MOVEMENT_TREE($player, $depth, undef, undef, undef, undef, undef, $_[0], $_[1], $sessid);
} else {
$depth = 2; # Usually about 20^$depth possibilities (but ten times as much iterates for including no movement).
&MOVEMENT_TREE($player, $depth);
}
foreach (keys %tmpalg) {
my $val = $tmpalg{$_};
push @{$key_list_by_value{$val}}, $_;
unless (defined($prio)) {
$prio = $val;
}
if ($val > $prio) {
$prio = $val;
}
}
if ($player == $user_mode && $prio != 'Inf') { # Invalid user input.
$player_turn--;
# push @{$diff{$player}{'warn'}} = 'Reverting an invalid set.';
undef $diff{$pplayer[$not_player[$player]]};
push @{$diff{$pplayer[$player]}{'status'}}, 0;
# redo TURN;
return %diff;
}
if (scalar keys %key_list_by_value > 0) {
for (my $ii = 0; $#{$key_list_by_value{$prio}} >= $ii; $ii++) {
$selection[$ii] = $key_list_by_value{$prio}[$ii];
}
$ice = int(rand($#selection+1));
} elsif ($user_mode != $player) { # The other side has checkmated you (the AI). The AI should know when to give up (even if it weren't for efficiency reasons).
# @{$diff{'msg'}{'gstatus'}}[$player] = 'Player ' . $player . ' resigns!';
push @{$diff{$pplayer[$player]}{'status'}}, 5;
if ($user_mode == -1) { # So, instead of performing winning moves (which will always be done at this tree depth), we have enough data here to revert back to some previous (hence valid) board state (with untravelled nodes). Rather than starting from scratch every time, this might be preferable for AI training. The importance of the first few chess moves shouldn't be undermined, however. Therefore, include some appropriate randomization.
#TODO: Usual DB writing followed by POC.
next TURN;
} else {
next TURN;
}
}
my $matches = grep {!/^[01][.]k[.]0_/} keys %tmpalg; # When only the king can move...
if ($matches == 0) {
$counter++;
if ($counter >= 2 && $player_turn > 24) { # End the game if the same applies to the opponent (only the king can move), and $player_turn have passed.
# @{$diff{'msg'}{'gstatus'}}[$player] = 'Only the kings can act. Stalemate...';
push @{$diff{$pplayer[$player]}{'status'}}, 4;
&POSTCHESS_CALC(&PRETTY_CALC(0, $player), 0);
# return;
}
}
if ($player_turn >= $action_limit) { # TODO: Is this needed when we have @pseudoinfinite_loop_check?
# @{$diff{'msg'}{'gstatus'}}[$player] = 'Total turn limit ' . ($player_turn*2) . ' reached: Stalemate...';
push @{$diff{$pplayer[$player]}{'status'}}, 3;
&POSTCHESS_CALC(&PRETTY_CALC(0, $player), 0);
# return;
}
if (($player_turn*2+$player) % ($loop_limit+1) == 0) { # 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...
my ($evenval1, $unevenval1, $evenval2, $unevenval2);
for (my $counter3 = 0; $#pseudoinfinite_loop_check >= $counter3; $counter3++) {
if ($counter3 > 1) {
if ($counter3 > 3) {
if ($counter3 % 2 == 0) {
if ($counter3 % 4 == 0) {
next if $evenval1 eq $pseudoinfinite_loop_check[$counter3];
last;
} elsif (($counter3+1) % 4 == 0) {
next if $unevenval1 eq $pseudoinfinite_loop_check[$counter3];
last;
} elsif (($counter3+2) % 4 == 0) {
next if $evenval2 eq $pseudoinfinite_loop_check[$counter3];
last;
} elsif (($counter3+3) % 4 == 0) {
next if $unevenval2 eq $pseudoinfinite_loop_check[$counter3];
last;
}
}
} elsif ($counter3 % 2 == 0) {
$evenval2 = $pseudoinfinite_loop_check[$counter3];
next;
} else {
$unevenval2 = $pseudoinfinite_loop_check[$counter3];
next;
}
} elsif ($counter3 % 2 == 0) {
$evenval1 = $pseudoinfinite_loop_check[$counter3];
next;
} else {
$unevenval1 = $pseudoinfinite_loop_check[$counter3];
next;
}
# @{$diff{'status'}}[$player] = 'Loop limit ' . $loop_limit . ' reached: Stalemate...';
push @{$diff{$pplayer[$player]}{'status'}}, 2;
&POSTCHESS_CALC(&PRETTY_CALC(0, $player), 0);
# return;
}
undef @pseudoinfinite_loop_check;
}
push @pseudoinfinite_loop_check, $selection[$ice];
push @{$diff{$pplayer[$player]}{'prio'}}, $prio;
push @{$diff{$pplayer[$player]}{'moveno'}}, ($ice+1) . '/' . ($#selection+1);
# @{$diff{'msg'}{'verbose'}}[$player] = $selection[$ice];
$what_i_did[$player]{$selection[$ice]} = $prio;
my $c = 0;
my $adest;
foreach (split /,/, $selection[$ice]) {
if (defined($keys[$c]) and $keys[$c] != $_) {
$adest = $_;
last;
}
$c++;
}
my $asrc = $keys[$c];
my $piece = $prop{$asrc};
push @{$diff{$pplayer[$player]}{'src'}}, $asrc;
push @{$diff{$pplayer[$player]}{'src'}}, join '', @{$piece};
push @{$diff{$pplayer[$player]}{'dst'}}, $adest;
# @{$diff{$player}{'move'}}[$player*2] = (join '', @{$piece}) . ' moves from ' . $asrc . ' to ' . $adest;
if (defined($prop{$adest})) {
push @{$diff{$pplayer[$player]}{'dst'}}, (join '', @{$prop{$adest}});
# push @{$diff{[$player]}{'move'}} = ' and takes ' . (join '', @{$prop{$adest}}) . '!';
if ($prop{$adest}[1] eq 'k') {
push @{$diff{$pplayer[$player]}{'status'}}, 1;
# push @{$diff{[$player]}{'win'}}, ' Player ' . $player . ' wins!';
&POSTCHESS_CALC(&PRETTY_CALC(0, $player), 1);
# return;
}
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};
}
# &PRETTY_CALC;
&CLEANUP_POSTTURN;
}
#exit;
# }
return %diff
}
#&CLEANUP_POSTGAME;
&INIT_BOARD;
&INIT_KEYS;
get '/move/:src/:dst' => sub {
if (session('init')) {
my %diff = &PROGRAM(route_parameters->get('src'), route_parameters->get('dst'), session); # Includes player input.
encode_json(\%diff);
}
};
any ['get', 'post'] => '/' => sub {
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).
my $setting_id = body_parameters->get('id');
redirect '/aaaaa';
}
}
} else {
if (session('init')) {
$sth8->execute(session('id'));
template 'index' => {board => $sth8->fetchall_arrayref()};
} else {
session 'init' => true;
template 'index' => {board => \@default_iboard};
}
}
};
true;

@ -0,0 +1,18 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes">
<title>Error 404</title>
<link rel="stylesheet" href="/css/error.css">
</head>
<body>
<h1>Error 404</h1>
<div id="content">
<h2>Page Not Found</h2><p>Sorry, this is the void.</p>
</div>
<div id="footer">
Powered by <a href="http://perldancer.org/">Dancer2</a>.
</div>
</body>
</html>

@ -0,0 +1,18 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes">
<title>Error 500</title>
<link rel="stylesheet" href="/css/error.css">
</head>
<body>
<h1>Error 500</h1>
<div id="content">
<h2>Internal Server Error</h2><p>Wooops, something went wrong</p>
</div>
<div id="footer">
Powered by <a href="http://perldancer.org/">Dancer2</a>.
</div>
</body>
</html>

@ -0,0 +1,86 @@
body {
font-family: Lucida,sans-serif;
}
h1 {
color: #AA0000;
border-bottom: 1px solid #444;
}
h2 { color: #444; }
pre {
font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
font-size: 12px;
border-left: 2px solid #777;
padding-left: 1em;
}
footer {
font-size: 10px;
}
span.key {
color: #449;
font-weight: bold;
width: 120px;
display: inline;
}
span.value {
color: #494;
}
/* these are for the message boxes */
pre.content {
background-color: #eee;
color: #000;
padding: 1em;
margin: 0;
border: 1px solid #aaa;
border-top: 0;
margin-bottom: 1em;
overflow-x: auto;
}
div.title {
font-family: "lucida console","monaco","andale mono","bitstream vera sans mono","consolas",monospace;
font-size: 12px;
background-color: #aaa;
color: #444;
font-weight: bold;
padding: 3px;
padding-left: 10px;
}
table.context {
border-spacing: 0;
}
table.context th, table.context td {
padding: 0;
}
table.context th {
color: #889;
font-weight: normal;
padding-right: 15px;
text-align: right;
}
.errline {
color: red;
}
pre.error {
background: #334;
color: #ccd;
padding: 1em;
border-top: 1px solid #000;
border-left: 1px solid #000;
border-right: 1px solid #eee;
border-bottom: 1px solid #eee;
overflow-x: auto;
}

@ -0,0 +1,63 @@
a {
display: block;
text-decoration: none;
outline-style: solid;
color: white;
background-image: url(i/tem.png);
}
ol > li li {
display: inline-block;
width: 32px;
}
#y-co {
display: flex;
flex-flow: column-reverse;
width: max-content;
}
#x-co {
display: inline-flex;
flex-flow: row;
width: max-content;
margin-top: 32px;
}
.x-co {
display: inline-block;
text-align: center;
width: 32px;
}
.features, .keys, .values {
list-style-type: none;
padding: 0;
margin: 0;
}
.features {
display: grid;
}
.key {
display: none;
}
.key .values {
display: none;
}
h3 > ul:hover .key {
display: inline-block;
}
.key:hover .values {
display: flex;
flex-flow: column;
position: fixed;
}
/*img {*/
/* position: relative;*/
/*}*/

@ -0,0 +1,16 @@
#!/usr/bin/env perl
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
use Dancer2;
use FindBin '$RealBin';
use Plack::Runner;
# For some reason Apache SetEnv directives don't propagate
# correctly to the dispatchers, so forcing PSGI and env here
# is safer.
set apphandler => 'PSGI';
set environment => 'production';
my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
die "Unable to read startup script: $psgi" unless -r $psgi;
Plack::Runner->run($psgi);

@ -0,0 +1,18 @@
#!/usr/bin/env perl
BEGIN { $ENV{DANCER_APPHANDLER} = 'PSGI';}
use Dancer2;
use FindBin '$RealBin';
use Plack::Handler::FCGI;
# For some reason Apache SetEnv directives don't propagate
# correctly to the dispatchers, so forcing PSGI and env here
# is safer.
set apphandler => 'PSGI';
set environment => 'production';
my $psgi = path($RealBin, '..', 'bin', 'app.psgi');
my $app = do($psgi);
die "Unable to read startup script: $@" if $@;
my $server = Plack::Handler::FCGI->new(nproc => 5, detach => 1);
$server->run($app);

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save