gashapwn
/
lpst
1
0
Fork 0
Code Issues 0 Pull Requests 0 Releases 0 Wiki Activity
Implementation of Lucifers Pastime
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
49 Commits
1 Branch
185KB
Branch: master
Branches Tags
${ item.name }
Create branch ${ searchTerm }
from 'master'
${ noResults }
lpst/LPST.pm

999 lines
25KB
Raw Permalink Blame History 

  1. #!/usr/bin/perl

  2. 

  3. package LPST;    

  4. 

  5. use warnings;

  6. use strict;

  7. 

  8. use utf8;

  9. 

  10. my $ARRAY = "ARRAY";

  11. 

  12. my $HAND_SIZE = 5;

  13. my $MAX_FT_SUMMON  = 16;

  14. 

  15. my $X_BOX_CHR = chr(0x2573);

  16. my $GRAY_BOX_CHR = chr(0x2591);

  17. my $ALT_US = chr(0x2017);

  18. my $ALT_PIPE = chr(0x2016);

  19. 

  20. my $SHADE_1_CHR = $GRAY_BOX_CHR;

  21. my $SHADE_2_CHR = $X_BOX_CHR;

  22. 

  23. my $PAD_AXIS = "     ";

  24. my $PAD_EVEN = "    ";

  25. my $PAD_ODD =  "   ";

  26. 

  27. my $HEX_1 = '-/--\-';

  28. my $HEX_2 = '| __ |';

  29. my $HEX_3 = '|    |';

  30. 

  31. my $HEX_S1_1 = '-/--\-';

  32. my $HEX_S1_2 = sprintf("|%s%s%s%s|", $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR);

  33. my $HEX_S1_3 = sprintf("|%s%s%s%s|", $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR);

  34. 

  35. my $HEX_S2_1 = '-/--\-';

  36. my $HEX_S2_2 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR);

  37. my $HEX_S2_3 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR);

  38. 

  39. my $HEX_S3_1 = '-/--\-';

  40. my $HEX_S3_2 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_1_CHR, $SHADE_1_CHR);

  41. my $HEX_S3_3 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_1_CHR, $SHADE_1_CHR);

  42. 

  43. my $HL_1 = "|____ ";

  44. my $HL_2 = $ALT_PIPE.$ALT_US.$ALT_US.$ALT_US.$ALT_US." ";

  45. 

  46. my $SUB_CHR = "_";

  47. 

  48. my $BLANK_CELL_CHR = $ALT_US;

  49. 

  50. my $PREF_1 = substr($HEX_1, -2, 2);

  51. my $PREF_2 = '  ';

  52. my $PREF_3 = '  ';

  53. 

  54. my $TRAIL_1 = substr($HEX_1, 0, 1);

  55. my $TRAIL_2 = substr($HEX_1, -1, 1);

  56. my $TRAIL_3 = substr($HEX_1, 0, 2);

  57. 

  58. # Pieces

  59. my $MG_A  =  "A";   # Apprentice

  60. my $MG_I  =  "I";   # Iron Maiden

  61. my $MG_N  =  "N";   # Nekomata

  62. my $MG_IT =  "It";  # Ittan-Momen

  63. my $MG_H  =  "H";   # Harpy

  64. my $MG_S  =  "S";   # Slime

  65. my $MG_RC =  "Rc";  # Redcap

  66. my $MG_HS =  "Hs";  # Holstaur

  67. my $MG_RO =  "Ro";  # Red Oni

  68. my $MG_B  =  "B";   # Blue Oni

  69. my $MG_P  =  "P";   # Preistess

  70. my $MG_IM =  "Im";  # Imp

  71. my $MG_F  =  "F";   # False Angel

  72. my $MG_QS =  "Qs";  # Queen slime

  73. my $MG_AU =  "Au";  # Automaton

  74. my $MG_SY =  "Sy";  # Sylph

  75. my $MG_Q  =  "Q";   # Queen

  76. 

  77. 

  78. my @MG_PI = (

  79.     $MG_A,  $MG_I,  $MG_N,  $MG_IT, $MG_H, $MG_S,

  80.     $MG_RC, $MG_HS, $MG_RO, $MG_B,  $MG_P, $MG_IM,

  81.     $MG_F,  $MG_QS, $MG_AU, $MG_SY, $MG_Q

  82.     );

  83. 

  84. # Players

  85. my $P1 = "P1";

  86. my $P2 = "P2";

  87. 

  88. my %OPPL = (

  89.     $P1 => $P2,

  90.     $P2 => $P1

  91.     );

  92. 

  93. my %HAND = (

  94.     $P1 => [],

  95.     $P2 => []

  96.     );

  97. 

  98. my $DIV = ":";

  99. 

  100. my %AXIS = (

  101.     "A" => 1,

  102.     "B" => 2,

  103.     "C" => 3,

  104.     "D" => 4,

  105.     "E" => 5,

  106.     "F" => 6,

  107.     "G" => 7,

  108.     "H" => 8,

  109.     "I" => 9,

  110.     "J" => 10,

  111.     "K" => 11

  112.     );

  113. my %AXIS_RV = map {

  114.     $AXIS{$_} => $_

  115. } keys(%AXIS);

  116. 

  117. package MoveStruct;

  118. use warnings;

  119. use strict;

  120. 

  121. sub new {

  122.     my $class = shift;

  123.     my $self = { @_ };

  124.     

  125.     die "invalid MoveStruct {\"mov\"}" unless $self->{"mov"};

  126.     die "invalid MoveStruct ->{\"type\"}" unless $self->{"type"};

  127.     die "invalid MoveStruct type" unless ref($self->{"mov"}) eq $ARRAY;

  128. 

  129.     return bless $self, $class;

  130. }

  131. 

  132. package LPST;    

  133. 

  134. #

  135. #     /--\ +1 

  136. #    | __ |

  137. #    |    |+1

  138. #     \--/ 

  139. #   -1 -1     

  140. #

  141. 

  142. # ODD

  143. # UP: 0, +1

  144. # DOWN: -1, -1

  145. 

  146. # EVEN

  147. # UP: +1, +1

  148. # DOWN: +0, -1

  149. 

  150. # [Row move, Diag move]

  151. 

  152. # Special cells

  153. my $EMPTY_CELL = "_";

  154. 

  155. # Shade enum

  156. my $SHADE_3_ENUM = 0b011;

  157. my $SHADE_2_ENUM = 0b010;

  158. my $SHADE_1_ENUM = 0b001;

  159. my $EMPTY_ENUM = 0;

  160. 

  161. my %SHADE = (

  162.     $SHADE_1_ENUM => [$HEX_S1_1, $HEX_S1_2, $HEX_S1_3],

  163.     $SHADE_2_ENUM => [$HEX_S2_1, $HEX_S2_2, $HEX_S2_3],

  164.     $SHADE_3_ENUM => [$HEX_S3_1, $HEX_S3_2, $HEX_S3_3],

  165.     $EMPTY_ENUM  => [$HEX_1, $HEX_2, $HEX_3]

  166.     );

  167. 

  168. my $MOVE_ENUM = $SHADE_1_ENUM;   

  169. my $BLOCK_ENUM = $SHADE_2_ENUM; 

  170. my $MOVBLOCK_ENUM = $SHADE_3_ENUM;   

  171. 

  172. my $ERR_C_1 = -1;

  173. 

  174. my %MOVE = (

  175.     $MG_A => [

  176. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVBLOCK_ENUM),

  177. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVBLOCK_ENUM)

  178. 	],

  179.     $MG_Q  => [

  180. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  181. 	MoveStruct->new("mov" => [ 1, 0], "type" => $MOVE_ENUM),

  182. 	MoveStruct->new("mov" => [-1, 0], "type" => $MOVE_ENUM),

  183. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVE_ENUM)

  184.     ],

  185.     $MG_I => [

  186. 	MoveStruct->new("mov" => [-1, 0], "type" => $BLOCK_ENUM),

  187. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  188. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM),

  189. 	MoveStruct->new("mov" => [ 0,-1], "type" => $BLOCK_ENUM),

  190. 	MoveStruct->new("mov" => [ 1, 0], "type" => $BLOCK_ENUM),

  191. 	MoveStruct->new("mov" => [ 1,-1], "type" => $BLOCK_ENUM)

  192.     ],

  193.     $MG_IT => [

  194. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVE_ENUM),

  195. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVE_ENUM),

  196. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  197. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM)

  198.     ],

  199.     $MG_N  => [

  200. 	MoveStruct->new("mov" => [-1, 2], "type" => $MOVE_ENUM),

  201. 	MoveStruct->new("mov" => [ 1,-2], "type" => $MOVE_ENUM),

  202. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  203. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM)

  204.     ],

  205.     $MG_H  => [

  206. 	MoveStruct->new("mov" => [-3, 2], "type" => $MOVE_ENUM),

  207. 	MoveStruct->new("mov" => [-1,-2], "type" => $MOVE_ENUM),

  208. 	MoveStruct->new("mov" => [ 1, 2], "type" => $MOVE_ENUM),

  209. 	MoveStruct->new("mov" => [ 3,-2], "type" => $MOVE_ENUM),

  210. 	MoveStruct->new("mov" => [ 0,-1], "type" => $BLOCK_ENUM),

  211. 	MoveStruct->new("mov" => [ 1,-1], "type" => $BLOCK_ENUM),

  212. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  213. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM)

  214.     ],

  215.     $MG_RC => [

  216. 	MoveStruct->new("mov" => [-1, 0], "type" => $MOVE_ENUM),

  217. 	MoveStruct->new("mov" => [-2, 0], "type" => $MOVE_ENUM),

  218. 	MoveStruct->new("mov" => [ 1, 0], "type" => $MOVE_ENUM),

  219. 	MoveStruct->new("mov" => [ 2, 0], "type" => $MOVE_ENUM),

  220. 	MoveStruct->new("mov" => [ 0,-1], "type" => $BLOCK_ENUM),

  221. 	MoveStruct->new("mov" => [ 1,-1], "type" => $BLOCK_ENUM),

  222. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  223. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM)

  224.     ],

  225.     $MG_S  => [

  226. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVE_ENUM),

  227. 	MoveStruct->new("mov" => [-2, 2], "type" => $MOVE_ENUM),

  228. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  229. 	MoveStruct->new("mov" => [ 0, 2], "type" => $MOVE_ENUM),

  230. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVE_ENUM),

  231. 	MoveStruct->new("mov" => [ 0,-2], "type" => $MOVE_ENUM),

  232. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVE_ENUM),

  233. 	MoveStruct->new("mov" => [ 2,-2], "type" => $MOVE_ENUM),

  234.     ],

  235.     $MG_HS => [

  236. 	MoveStruct->new("mov" => [-3, 1], "type" => $MOVE_ENUM),

  237. 	MoveStruct->new("mov" => [-2,-1], "type" => $MOVE_ENUM),

  238. 	MoveStruct->new("mov" => [ 2, 1], "type" => $MOVE_ENUM),

  239. 	MoveStruct->new("mov" => [ 3,-1], "type" => $MOVE_ENUM),

  240. 	MoveStruct->new("mov" => [-2, 1], "type" => $BLOCK_ENUM),

  241. 	MoveStruct->new("mov" => [ 1, 1], "type" => $BLOCK_ENUM),

  242. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  243. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM)

  244.     ],

  245.     $MG_RO => [

  246. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVE_ENUM),

  247. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  248. 	MoveStruct->new("mov" => [ 1, 1], "type" => $MOVE_ENUM),

  249. 	MoveStruct->new("mov" => [ 1,-2], "type" => $MOVE_ENUM),

  250. 	MoveStruct->new("mov" => [-1, 0], "type" => $BLOCK_ENUM),

  251. 	MoveStruct->new("mov" => [ 1, 0], "type" => $BLOCK_ENUM)

  252.     ],

  253.     $MG_B  => [

  254. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVE_ENUM),

  255. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  256. 	MoveStruct->new("mov" => [ 0,-2], "type" => $MOVE_ENUM),

  257. 	MoveStruct->new("mov" => [ 2,-2], "type" => $MOVE_ENUM),

  258. 	MoveStruct->new("mov" => [ 0,-1], "type" => $BLOCK_ENUM),

  259. 	MoveStruct->new("mov" => [ 1,-1], "type" => $BLOCK_ENUM)

  260.     ],

  261.     $MG_P  => [

  262. 	MoveStruct->new("mov" => [-4, 2], "type" => $MOVE_ENUM),

  263. 	MoveStruct->new("mov" => [-2, 1], "type" => $MOVBLOCK_ENUM),

  264. 	MoveStruct->new("mov" => [-2,-2], "type" => $MOVE_ENUM),

  265. 	MoveStruct->new("mov" => [-1,-1], "type" => $MOVBLOCK_ENUM),

  266. 	MoveStruct->new("mov" => [ 1, 1], "type" => $MOVBLOCK_ENUM),

  267. 	MoveStruct->new("mov" => [ 2,-1], "type" => $MOVBLOCK_ENUM),

  268. 	MoveStruct->new("mov" => [ 2, 2], "type" => $MOVE_ENUM),

  269. 	MoveStruct->new("mov" => [ 4,-2], "type" => $MOVE_ENUM)

  270.     ],

  271.     $MG_IM => [

  272. 	MoveStruct->new("mov" => [-2, 1], "type" => $MOVBLOCK_ENUM),

  273. 	MoveStruct->new("mov" => [-1,-1], "type" => $MOVBLOCK_ENUM),

  274. 	MoveStruct->new("mov" => [-1, 2], "type" => $MOVBLOCK_ENUM),

  275. 	MoveStruct->new("mov" => [ 1, 1], "type" => $MOVBLOCK_ENUM),

  276. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVE_ENUM),

  277. 	MoveStruct->new("mov" => [ 1,-2], "type" => $BLOCK_ENUM),

  278. 	MoveStruct->new("mov" => [ 2,-1], "type" => $MOVBLOCK_ENUM)

  279.     ],

  280.     $MG_F  => [

  281. 	MoveStruct->new("mov" => [-1, 0], "type" => $MOVE_ENUM),

  282. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVE_ENUM),

  283. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  284. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVE_ENUM),

  285. 	MoveStruct->new("mov" => [ 1, 0], "type" => $MOVE_ENUM),

  286. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVE_ENUM),

  287. 	

  288. 	MoveStruct->new("mov" => [ 0, 2], "type" => $BLOCK_ENUM),

  289. 	MoveStruct->new("mov" => [ 0,-2], "type" => $BLOCK_ENUM),

  290. 	MoveStruct->new("mov" => [ 1, 1], "type" => $BLOCK_ENUM),

  291. 	MoveStruct->new("mov" => [ 1,-2], "type" => $BLOCK_ENUM),

  292. 	MoveStruct->new("mov" => [ 2, 0], "type" => $BLOCK_ENUM),

  293. 	MoveStruct->new("mov" => [ 2,-1], "type" => $BLOCK_ENUM),

  294. 	MoveStruct->new("mov" => [ 2,-2], "type" => $BLOCK_ENUM),

  295. 	MoveStruct->new("mov" => [-1, 2], "type" => $BLOCK_ENUM),

  296. 	MoveStruct->new("mov" => [-1,-1], "type" => $BLOCK_ENUM),

  297. 	MoveStruct->new("mov" => [-2, 0], "type" => $BLOCK_ENUM),

  298. 	MoveStruct->new("mov" => [-2, 1], "type" => $BLOCK_ENUM),

  299. 	MoveStruct->new("mov" => [-2, 2], "type" => $BLOCK_ENUM)

  300.     ],

  301.     $MG_QS => [

  302. 	MoveStruct->new("mov" => [-3, 3], "type" => $MOVE_ENUM),

  303. 	MoveStruct->new("mov" => [-2, 2], "type" => $MOVE_ENUM),

  304. 	MoveStruct->new("mov" => [-2, 0], "type" => $MOVE_ENUM),

  305. 	MoveStruct->new("mov" => [-1, 0], "type" => $MOVE_ENUM),

  306. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVE_ENUM),

  307. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVE_ENUM),

  308. 	MoveStruct->new("mov" => [ 0, 2], "type" => $MOVE_ENUM),

  309. 	MoveStruct->new("mov" => [ 0, 3], "type" => $MOVE_ENUM),

  310. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVE_ENUM),

  311. 	MoveStruct->new("mov" => [ 0,-2], "type" => $MOVE_ENUM),

  312. 	MoveStruct->new("mov" => [ 0,-3], "type" => $MOVE_ENUM),

  313. 	MoveStruct->new("mov" => [ 1, 0], "type" => $MOVE_ENUM),

  314. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVE_ENUM),

  315. 	MoveStruct->new("mov" => [ 2, 0], "type" => $MOVE_ENUM),

  316. 	MoveStruct->new("mov" => [ 2,-2], "type" => $MOVE_ENUM),

  317. 	MoveStruct->new("mov" => [ 3,-3], "type" => $MOVE_ENUM),

  318. 	MoveStruct->new("mov" => [ 3, 0], "type" => $MOVE_ENUM),

  319. 	MoveStruct->new("mov" => [-3, 0], "type" => $MOVE_ENUM)

  320.     ],

  321.     $MG_AU => [

  322. 	MoveStruct->new("mov" => [-1, 0], "type" => $MOVBLOCK_ENUM),

  323. 	MoveStruct->new("mov" => [-1, 1], "type" => $MOVBLOCK_ENUM),

  324. 	MoveStruct->new("mov" => [ 0, 1], "type" => $MOVBLOCK_ENUM),

  325. 	MoveStruct->new("mov" => [ 0,-1], "type" => $MOVBLOCK_ENUM),

  326. 	MoveStruct->new("mov" => [ 1, 0], "type" => $MOVBLOCK_ENUM),

  327. 	MoveStruct->new("mov" => [ 1,-1], "type" => $MOVBLOCK_ENUM),

  328. 	MoveStruct->new("mov" => [ 0, 2], "type" => $BLOCK_ENUM),

  329. 	MoveStruct->new("mov" => [ 0,-2], "type" => $BLOCK_ENUM),

  330. 	MoveStruct->new("mov" => [ 1, 1], "type" => $BLOCK_ENUM),

  331. 	MoveStruct->new("mov" => [ 1,-2], "type" => $BLOCK_ENUM),

  332. 	MoveStruct->new("mov" => [ 2,-1], "type" => $BLOCK_ENUM),

  333. 	MoveStruct->new("mov" => [ 2,-2], "type" => $BLOCK_ENUM),

  334. 	MoveStruct->new("mov" => [-1, 2], "type" => $BLOCK_ENUM),

  335. 	MoveStruct->new("mov" => [-1,-1], "type" => $BLOCK_ENUM),

  336. 	MoveStruct->new("mov" => [-2, 1], "type" => $BLOCK_ENUM),

  337. 	MoveStruct->new("mov" => [-2, 2], "type" => $BLOCK_ENUM)

  338.     ],

  339.     $MG_SY => [

  340. 	MoveStruct->new("mov" => [-4, 4], "type" => $MOVE_ENUM),

  341. 	MoveStruct->new("mov" => [-3, 3], "type" => $MOVE_ENUM),

  342. 	MoveStruct->new("mov" => [-3, 2], "type" => $MOVBLOCK_ENUM),

  343. 	MoveStruct->new("mov" => [-1,-2], "type" => $MOVBLOCK_ENUM),

  344. 	MoveStruct->new("mov" => [ 0,-4], "type" => $MOVE_ENUM),

  345. 	MoveStruct->new("mov" => [ 0,-3], "type" => $MOVE_ENUM),

  346. 	MoveStruct->new("mov" => [ 0, 3], "type" => $MOVE_ENUM),

  347. 	MoveStruct->new("mov" => [ 0, 4], "type" => $MOVE_ENUM),

  348. 	MoveStruct->new("mov" => [ 1, 2], "type" => $MOVBLOCK_ENUM),

  349. 	MoveStruct->new("mov" => [ 3,-2], "type" => $MOVBLOCK_ENUM),

  350. 	MoveStruct->new("mov" => [ 3,-3], "type" => $MOVE_ENUM),

  351. 	MoveStruct->new("mov" => [ 4,-4], "type" => $MOVE_ENUM),

  352. 	MoveStruct->new("mov" => [-1, 1], "type" => $BLOCK_ENUM),

  353. 	MoveStruct->new("mov" => [ 0, 1], "type" => $BLOCK_ENUM),

  354. 	MoveStruct->new("mov" => [ 0,-1], "type" => $BLOCK_ENUM),

  355. 	MoveStruct->new("mov" => [ 1,-1], "type" => $BLOCK_ENUM)

  356.     ]

  357.     );

  358. 

  359. my %board;

  360. 

  361. # Display pieces

  362. #==================================================

  363. 

  364. sub get_pi_str($){

  365.     my ($p) = (shift);

  366.     $p =~ s/($P1|$P2)$DIV//;

  367.     $p .= "_" if length($p) < 2;

  368.     return $p;

  369. }

  370. 

  371. sub sub_pi_str($$$){

  372.     my ($p, $c0, $hex) = (shift, shift, shift);

  373.     my $s0;

  374. 

  375.     $p = get_pi_str($p);

  376.     $s0 = $hex;

  377.     

  378.     unless($p eq "__"){

  379. 	substr($s0, 2,2) = $p;

  380.     }

  381.     

  382.     if($c0 % 2 == 0){

  383. 	$s0 =~ s/$SUB_CHR/$BLANK_CELL_CHR/g;

  384.     }

  385. 

  386.     return $s0;

  387. }

  388. 

  389. # Display shade

  390. #==================================================

  391. 

  392. sub apply_shade($$$){

  393.     my ($self, $not, $en) = (shift, shift, shift);

  394. 

  395.     $self->{"sc"}{$not} = $en unless grep(/^$not$/, keys( %{$self->{"sc"}} ));

  396.     $self->{"sc"}{$not} = $MOVBLOCK_ENUM unless $self->{"sc"}{$not} == $en;

  397. }

  398. 

  399. sub get_shade_en($$){

  400.     my ($self, $not) = (shift, shift);

  401.     return $self->{"sc"}{$not} if (grep /^$not$/, keys( %{$self->{"sc"}} ));    

  402.     return $EMPTY_ENUM;

  403. }

  404. 

  405. sub get_shade_hex($){

  406.     my $en = shift;

  407.     return $SHADE{$en};

  408. }

  409. 

  410. sub get_cell_shade($$$){

  411.     my ($self, $r0, $c0) = (shift, shift, shift);

  412.     my $not;

  413.     

  414.     $not = cell_index_rev($c0, $r0);

  415.     return get_shade_hex($self->get_shade_en($not));

  416. }

  417. 

  418. 

  419. 

  420. 

  421. # Display lines

  422. #==================================================

  423. 

  424. sub disp_1($$$){

  425.     my ($self, $r0, $c0) = (shift, shift, shift);

  426.     my $hex;

  427. 

  428.     $hex = $self->get_cell_shade($r0, $c0)->[0];

  429.     

  430.     return $hex;

  431. }

  432. 

  433. sub disp_2($$$){

  434.     my ($self, $r0, $c0) = (shift, shift, shift);

  435.     my $p;

  436.     my $not;

  437.     my $hex;

  438. 

  439.     $hex = $self->get_cell_shade($r0, $c0)->[1];

  440.     $not = cell_index_rev($c0, $r0);

  441. 

  442.     $p = $self->{"board"}{$not};

  443.     

  444.     return sub_pi_str($p, $c0, $hex);

  445. }

  446. 

  447. sub disp_3($$$){

  448.     my ($self, $r0, $c0) = (shift, shift, shift);

  449.     my $hex;

  450.     

  451.     $hex = $self->get_cell_shade($r0, $c0)->[2];

  452.     

  453.     return $hex;

  454. }

  455. 

  456. sub disp_y_axis($$$$){

  457.     my ($s0, $s1, $s2, $r0) = @_;

  458.     my $n0;

  459.     

  460.     $n0 = length($r0);

  461.     

  462.     $s0 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_1;

  463.     $s1 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_2;

  464.     $s1 =~ s/^ {$n0}/$r0/;

  465.     $s2 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_3;

  466. 

  467.     return ($s0, $s1, $s2);

  468. }

  469. 

  470. # Display cell

  471. #==================================================

  472. 

  473. sub add_cell($$$$$$){

  474.     my ($self, $s0, $s1, $s2, $r0, $c0) = @_;

  475. 

  476.     $s0 .= $self->disp_1($r0, $c0);

  477.     $s1 .= $self->disp_2($r0, $c0);

  478.     $s2 .= $self->disp_3($r0, $c0);

  479. 

  480.     return ($s0, $s1, $s2);

  481. }

  482. 

  483. sub disp_0($){

  484.     my ($self, $r0) = (shift, shift);

  485. 

  486.     my ($s0, $s1, $s2);

  487. 

  488.     # Append the y axis

  489.     ($s0, $s1, $s2) = disp_y_axis($s0, $s1, $s2, $r0);

  490. 

  491.     # Iterate through the cells

  492.     for my $i (1..11){

  493. 	($s0, $s1, $s2) = $self->add_cell($s0, $s1, $s2, $r0, $i);

  494.     }

  495.     

  496.     return $s0."\n".$s1."\n".$s2."\n";

  497. }

  498. 

  499. # Display row

  500. #==================================================

  501. 

  502. sub disp_row($$){

  503.     my $row;

  504.     my ($self, $r0) = (shift, shift);

  505. 

  506.     # $r0 = shift;

  507. 

  508.     $row = $self->disp_0($r0);

  509. 

  510.     # Handle trailing characters

  511.     if($r0 % 2 == 1){

  512. 	# Trim the start of the first line

  513. 	$row =~ s/$TRAIL_1/ /;

  514. 	# Trim the end of the first line

  515. 	$row =~ s/\n/$TRAIL_3\n/

  516.     }else{

  517. 	# Trim the end of the last line

  518. 	$row =~ s/$TRAIL_2\n/ \n/m;

  519.     }

  520.     

  521.     return $row;

  522. }

  523. 

  524. sub disp_trailing_row(){

  525.     my $s0;

  526.     my $s1;

  527.     

  528.     $s0 = $PAD_EVEN.$PREF_1;

  529. 

  530.     # Clear some chars from

  531.     # our hex patterns

  532.     $s1 = $HEX_1;

  533.     substr($s1, 2,2) = "  ";

  534. 

  535.     # Append hex pattern to

  536.     # trailing row

  537.     for my $i (1..11){	

  538. 	$s0 .= $s1;

  539.     }

  540.     # Clear one last pair of

  541.     # chrs

  542.     substr($s0, -2,2) = "  ";

  543.     $s0 .= "\n";

  544.     

  545.     return $s0;

  546. }

  547. 

  548. sub disp_x_axis(){

  549.     my $s0;

  550.     

  551.     $s0 = $PAD_AXIS;

  552.     $s0 .= join(

  553. 	$PAD_AXIS, map{

  554. 	    $AXIS_RV{$_}

  555. 	}(1..11));

  556.     $s0 .= "\n";

  557.     

  558.     $s0 .= $PAD_AXIS;

  559.     $s0 .= join(

  560. 	"", map{

  561. 	    $_ % 2 == 1 ? $HL_1 : $HL_2

  562. 	}(1..11));

  563.     $s0 .= "\n";

  564.     

  565.     return $s0

  566. }

  567. 

  568. # Display board

  569. #==================================================

  570. 

  571. sub disp_board($){

  572.     my $self = shift;

  573.     my $b;

  574.     

  575.     for my $i (map {11-$_+1} (1..11)) {

  576. 	$b .= $self->disp_row($i);

  577.     }

  578.     $b .= disp_trailing_row();

  579.     $b .= disp_x_axis();

  580.     $b =~ s/$TRAIL_1$TRAIL_3\n/\n/m;

  581. 

  582.     for my $i (1..11-1){

  583. 	substr($b, 2+6*$i, 2) = "  ";

  584.     }

  585.     printf("%s", $b);

  586. }

  587. 

  588. 

  589. 

  590. 

  591. # Caclulate movement

  592. #==================================================

  593. sub pi_split($$$){

  594.     my ($self, $not, $i0) = (shift, shift, shift);

  595.     return (split(/$DIV/, $self->{"board"}{$not}))[$i0];

  596. }

  597. 

  598. sub cell_pi($$){

  599.     my ($self, $not) = (shift, shift);

  600.     return $self->pi_split($not, 1);

  601. }

  602. 

  603. sub cell_pl($$){

  604.     my ($self, $not) = (shift, shift);

  605.     return $self->pi_split($not, 0);

  606. }

  607. 

  608. sub cell_index_rev($$){

  609.     return $AXIS_RV{$_[0]}.$_[1];

  610. }

  611. 

  612. sub cell_index($){

  613.     my $chr1 = substr($_[0], 0,1);

  614.     my $chr2 = substr($_[0], 1,length($_[0])-1);

  615.     return ($AXIS{$chr1}, $chr2);

  616. }

  617. 

  618. sub apply_shift($$){

  619.     my ($not, $my_shift) = (shift, shift);

  620.     my $r0;

  621.     my $c0;

  622. 

  623.     ($c0, $r0) = cell_index($not);

  624. 

  625.     $r0 += $my_shift->[1];

  626.     $c0 += $my_shift->[0];

  627.     return $ERR_C_1 if $r0 > 11 or $c0 > 11 or $r0 < 1 or $c0 < 1;

  628.     return cell_index_rev($c0, $r0);

  629. }

  630. 

  631. sub calc_new_cell($$){

  632.     my ($not, $mov) = (shift, shift);

  633.     my ($c0, $r0) = cell_index($not);

  634.     

  635.     my $x_shift;

  636.     my $y_shift;

  637. 

  638.     my $n0;

  639.     my $ni;

  640. 

  641.     # get y_shift

  642.     $y_shift = $mov->[1];

  643.     

  644.     # get x_shift

  645.     $x_shift = $mov->[0];

  646.     

  647.     # make x_shift adjustment

  648.     $ni = $y_shift != 0 ? ($y_shift / abs($y_shift)) : 1;

  649.     $n0 = ($r0 + (($ni + 1)/2) ) % 2;

  650.     

  651.     $x_shift += int(($y_shift + ($n0 * $ni)) / 2);

  652. 

  653.     return apply_shift($not, [$x_shift, $y_shift]);

  654. }

  655. 

  656. sub mirror_mov($){

  657.     my $mov = shift;

  658.     

  659.     return MoveStruct->new(

  660. 	"mov" => [$mov->{"mov"}[0] * -1, $mov->{"mov"}[1] * -1],

  661. 	"type" => $mov->{"type"}

  662. 	);

  663. }

  664. 

  665. sub get_mov($$$){

  666.     my ($pi, $en, $apl) = (shift, shift, shift);

  667. 

  668.     my @mv1;

  669. 

  670.     @mv1 = grep {

  671. 	($_->{"type"} & $en) != 0

  672.     } @{$MOVE{$pi}};

  673. 

  674.     my ($t1, $t2) = (0, 0);

  675.     if($apl eq $P2){

  676. 	@mv1 = map {

  677. 	    mirror_mov($_)

  678. 	} @mv1;

  679.     }

  680. 

  681.     return \@mv1;

  682. }

  683. 

  684. sub find_all_mov($$$){

  685.     my ($self, $not, $en) = (shift, shift, shift);

  686.     my $pi;

  687.     my @mv1;

  688.     my $apl;

  689. 

  690.     $pi = $self->cell_pi($not);

  691.     $apl = $self->cell_pl($not);

  692.     @mv1 = @{ get_mov($pi, $en, $apl) };

  693. 

  694.     return grep {

  695. 	$_ if $_->[0] ne $ERR_C_1

  696.     } map {

  697. 	[

  698. 	 calc_new_cell($not, $_->{"mov"}),

  699. 	 $_->{"type"}

  700. 	]

  701.     } @mv1;

  702. }

  703. 

  704. sub shade_pi_mvmt($$$){

  705.     my ($self, $not, $en) = (shift, shift, shift);

  706.     my $c1;

  707.     my @mv1;

  708. 

  709.     @mv1 = $self->find_all_mov($not, $en);

  710.     for my $mv (@mv1){

  711. 	$self->apply_shade($mv->[0], $mv->[1]);

  712.     }

  713. }

  714. 

  715. sub shade_all_mvmt($$$){

  716.     my ($self, $pl, $en) = (shift, shift, shift);

  717.     my @pi1;

  718.     

  719.     @pi1 = grep {

  720. 	$self->cell_pl($_) eq $pl

  721.     } keys(%{$self->{"board"}});

  722. 

  723.     for my $el (@pi1){

  724. 	$self->shade_pi_mvmt($el, $en);

  725.     }

  726. }

  727. 

  728. sub shade_all_p1_mvmt($){

  729.     my $self = shift;

  730.     $self->shade_all_mvmt($P1, $MOVBLOCK_ENUM);

  731. }

  732. 

  733. sub shade_all_p2_mvmt($){

  734.     my $self = shift;

  735.     $self->shade_all_mvmt($P2, $MOVBLOCK_ENUM);

  736. }

  737. 

  738. sub get_block_cell($$){

  739.     my ($self, $pl) = (shift, shift);

  740.     

  741.     return map {

  742. 	$_->[0]

  743.     } map {

  744. 	( $self->find_all_mov($_, $BLOCK_ENUM) );

  745.     } grep {

  746. 	$self->cell_pl($_) eq $pl

  747.     } keys(%{$self->{"board"}});

  748. }

  749. 

  750. sub check_valid_card($$){

  751.     my ($self, $s1) = (shift, shift);

  752.     die "invalid card/piece - $s1" unless grep {

  753. 	$_ =~ /^$s1$/i

  754.     } @MG_PI;

  755. }

  756. 

  757. sub check_empty_cell($$){

  758.     my ($self, $hx1) = (shift, shift);

  759.     $hx1 = uc $hx1;

  760. 

  761.     $self->check_valid_cell($hx1);

  762.     die "piece in cell $hx1" if $self->{"board"}{$hx1} ne $EMPTY_CELL;    

  763. }

  764. 

  765. sub check_nonempty_cell($$){

  766.     my ($self, $hx1) = (shift, shift);

  767.     $hx1 = uc $hx1;

  768. 

  769.     $self->check_valid_cell($hx1);

  770.     die "no piece in cell $hx1" if $self->{"board"}{$hx1} eq $EMPTY_CELL;

  771. }

  772. 

  773. sub check_valid_cell($$){

  774.     my ($self, $hx1) = (shift, shift);

  775.     $hx1 = uc $hx1;

  776.     

  777.     die "invalid cell - $hx1" unless grep {

  778. 	$hx1 =~ /^$_$/i

  779.     } keys %{$self->{"board"}};

  780.     # } keys %board;

  781. }

  782. 

  783. sub check_match_pi($$$$){

  784.     my ($self, $hx1, $pi) = (shift, shift, shift);

  785.     my $hx2;

  786. 

  787.     $hx2 = $self->cell_pi($hx1);

  788.     die "$pi - Wrong piece notation for $hx1 should be $hx2" if $hx2 ne $pi;

  789. }

  790. 

  791. sub check_src_cell($$$$){

  792.     my ($self, $hx1, $apl, $pi) = (shift, shift, shift, shift);

  793.     $hx1 = uc $hx1;

  794. 

  795.     $self->check_nonempty_cell($hx1);

  796.     $self->check_match_pi($hx1, $pi);

  797.     die "This cell is not owned by $apl" if $self->cell_pl($hx1) ne $apl;

  798. }

  799. 

  800. sub check_valid_player($$){

  801.     my ($self, $apl) = (shift, shift);

  802.     die "invalid player - $apl" unless grep {

  803. 	$apl =~ /^$_$/

  804.     } keys %HAND;

  805. }

  806. 

  807. sub check_valid_piece($$$){

  808.     my ($self, $pi, $apl) = (shift, shift, shift);

  809.     $self->check_valid_card($pi);

  810.     die "player $apl does not have $pi" unless grep {

  811. 	$pi =~ /$_$/

  812.     } @{$HAND{$apl}};

  813. }

  814. 

  815. sub check_block($$$){

  816.     my ($self, $s0, $apl) = (shift, shift, shift);

  817.     for my $c0 ($self->get_block_cell($OPPL{$apl})){

  818. 	die "summon to cell $s0 is blocked" if $s0 eq $c0;

  819.     }

  820. }

  821. 

  822. sub check_valid_mov($$$){

  823.     my ($self, $src, $dst) = (shift, shift, shift);

  824.     $src = uc $src;

  825.     die "not valid move" unless grep {$dst eq $_->[0]} $self->find_all_mov($src, $MOVE_ENUM);

  826. }

  827. 

  828. sub check_sz($$$){

  829.     my ($self, $hx1, $apl) = (shift, shift, shift);

  830.     my ($c0, $r0) = cell_index($hx1);

  831. 

  832.     die "$hx1 not in start zone" if($r0 > 3 && $apl eq $P1);

  833.     die "$hx1 not in start zone" if($r0 < 8 && $apl eq $P2);

  834. }

  835. 

  836. sub draw($$$){

  837.     my ($self, $s0, $apl) = (shift, shift, shift);

  838. 

  839.     my $i = 0;

  840.     for my $s1 (uniq( [split(/ /, $s0)] )){

  841. 	$i++;

  842. 	$self->check_valid_card($s1);

  843. 	push(@{$HAND{$apl}}, $s1);

  844.     }

  845.     die "draw() $s0 - hand size less than $HAND_SIZE. Possible duplicate card?" if $i < $HAND_SIZE;

  846. }

  847. 

  848. sub summon($$$){

  849.     my ($self, $s0, $apl) = (shift, shift, shift);

  850.     my ($pi, $hx1) = $s0 =~ /([A-Za-z]{1,2})([A-Za-z][0-9]{1,})/;

  851.     $hx1 = uc $hx1;

  852.     $self->check_empty_cell($hx1);

  853.     $self->check_valid_player($apl);

  854.     $self->check_valid_piece($pi, $apl);

  855.     $self->check_block($hx1, $apl);

  856.     $self->{"board"}{uc $hx1} = $apl.$DIV.$pi;

  857. }

  858. 

  859. sub sz_summon($$$){

  860.     my ($self, $s0, $apl) = (shift, shift, shift);

  861.     my ($pi, $hx1) = $s0 =~ /([A-Za-z]{1,2})([A-Za-z][0-9]{1,})/;

  862.     $hx1 = uc $hx1;

  863.     $self->check_sz($hx1, $apl);

  864.     $self->summon($s0, $apl);

  865. }

  866. 

  867. sub ft_summon($$$){

  868.     my ($self, $s0, $apl) = (shift, shift, shift);

  869.     die "Must summon queen on first turn" unless $s0 =~ /$MG_Q[A-ka-k]{1,2}[0-9]{1,2}/;

  870.     die "Max summons on first turn is $MAX_FT_SUMMON" if ( scalar (() = $s0 =~ /\*/g) > $MAX_FT_SUMMON );

  871. 

  872.     for my $mv1 ($s0 =~ /\b[A-Za-z]{2,3}[0-9]{1,2}\*/g){

  873. 	$self->sz_summon($mv1, $apl);

  874.     }

  875. }

  876. 

  877. sub mov($$$){

  878.     my ($self, $s0, $apl) = (shift, shift, shift);

  879.     my ($pi, $src, $dst) = $s0 =~ /([A-Za-z]){1,2}([A-Za-z][0-9]{1,2})([A-Za-z][0-9]{1,2})$/;

  880. 

  881.     $src = uc $src;

  882.     $dst = uc $dst;

  883.     $self->check_valid_player($apl);

  884.     $self->check_src_cell($src, $apl, $pi);

  885.     $self->check_empty_cell($dst);

  886.     $self->check_valid_mov($src, $dst);

  887.     $self->{"board"}{$dst} = $self->cell_pl($src).$DIV.$self->cell_pi($src);

  888.     $self->{"board"}{$src} = $EMPTY_CELL;

  889. }

  890. 

  891. sub new {

  892.     my $class = shift;

  893.     my $self = { @_ };

  894. 

  895.     $self->{"board"} = { map {

  896. 	$_ => $EMPTY_CELL

  897.     } map {

  898. 	my $l0;

  899. 	$l0 = $_;

  900. 	(map {$l0.$_} ("1".."11"))

  901.     } map {

  902. 	$AXIS_RV{$_}

  903.     }(1...11) };

  904.     # Creates a hash of the the form

  905.     # $board{cell_notation} = piece_enum

  906.     %board = map {

  907. 	$_ => $EMPTY_CELL

  908.     } map {

  909. 	my $l0;

  910. 	$l0 = $_;

  911. 	(map {$l0.$_} ("1".."11"))

  912.     } map {

  913. 	$AXIS_RV{$_}

  914.     }(1...11);

  915. 

  916.     $self->{"sc"} = {};

  917.     

  918.     # Both players start with a

  919.     # queen

  920.     push(@{$HAND{$P1}}, "Q");

  921.     push(@{$HAND{$P2}}, "Q");

  922. 

  923.     return bless $self, $class;

  924. }

  925. 

  926. sub uniq($){

  927.     my %h0;

  928.     return grep { !$h0{$_}++ } @{$_[0]};

  929. }

  930. 

  931. sub P1 {

  932.     return $P1;

  933. }

  934. sub P2 {

  935.     return $P2;

  936. }

  937. 

  938. sub MG_A {

  939.     return $MG_A;

  940. }

  941. sub MG_I{

  942.     return $MG_I;

  943. }

  944. sub MG_N{

  945.     return $MG_N;

  946. }

  947. sub MG_IT{

  948.     return $MG_I;

  949. }

  950. sub MG_H{

  951.     return $MG_H;

  952. }

  953. sub MG_S{

  954.     return $MG_S;

  955. }

  956. sub MG_RC{

  957.     return $MG_RO;

  958. }

  959. sub MG_HS{

  960.     return $MG_H;

  961. }

  962. sub MG_RO{

  963.     return $MG_RC;

  964. }

  965. sub MG_B{

  966.     return $MG_B;

  967. }

  968. sub MG_P{

  969.     return $MG_P;

  970. }

  971. sub MG_IM{

  972.     return $MG_I;

  973. }

  974. sub MG_F{

  975.     return $MG_F;

  976. }

  977. sub MG_QS{

  978.     return $MG_QS;

  979. }

  980. sub MG_AU{

  981.     return $MG_A;

  982. }

  983. sub MG_SY{

  984.     return $MG_SY;

  985. }

  986. sub MG_Q{

  987.     return $MG_Q;

  988. }

  989. 

  990. 

  991. binmode(STDOUT, ":utf8");

  992. 

  993. return 1;

  994. 

  995. 

  996. 

  997.