LPST.pm - first turn summons ntvl.pl - updated test cases

#ntvl.pl#

@@ -1,119 +0,0 @@
-ggggg#!/usr/bin/perl
-
-package main;
-
-use warnings;
-use strict;
-
-use lib './';
-use LPST;
-
-# Move types
-my $SUMMON    = 0b00000001;
-my $MOVE      = 0b00000010;
-my $CAPTURE   = 0b00000100;
-my $SACRIFICE = 0b00001000;
-# my $SPELL     = 0b10000000;
-my $DRAW      = 0b01000000;
-
-sub is_summon($){
-   return $_[0] =~ /\*/ ? $SUMMON : 0;
-}
-
-sub is_move($){
-    return $_[0] =~ /([A-Za-z]{1,2}[0-9]{1,2}){2}/ ? $MOVE : 0;
-}
-
-sub is_capture($){
-    return $_[0] =~ /\~/ ? $CAPTURE : 0;
-}
-
-sub is_sacrifice($){
-    return $_[0] =~ /([A-Za-z]{1,2}[0-9]{1,2}' ?){2}/ ? $SACRIFICE : 0;
-}
-
-sub is_draw($){
-    return $_[0]  <= 1 ? $DRAW : 0;
-}
-
-sub draw($$$){
-    my ($b, $s0, $apl) = (shift, shift, shift);
-    die "invalid draw() syntax $s0" unless $s0 =~ /^([A-Za-z]{1,2} ){4}[A-Za-z]{1,2}$/;
-    $b->draw($s0, $apl);
-}
-
-sub mt2($$$$){
-    my ($b, $s0, $tc, $apl) = (shift, shift, shift, shift);
-
-    # return $MOVE if $s0 =~ /([A-Za-z]{1,2}[0-9]{1,2}){2}/;
-    # return $CAPTURE if $s0 =~ /\~/;
-    # return $SACRIFICE if $s0 =~ /([A-Za-z]{1,2}[0-9]{1,2}' ?){2}/;
-    # return $DRAW if $tc <= 1;
-
-    draw($b, $s0, $apl) if is_draw($tc);
-}
-
-sub mt1($$$){
-    my ($s0, $tc, $apl) = (shift, shift, shift);
-    return is_summon($s0) ||
-	is_move($s0) ||
-	is_capture($s0) ||
-	is_sacrifice($s0) ||
-	is_draw($tc);
-}
-
-sub f2($$$){
-    my ($s0, $tc, $apl) = (shift, shift, shift);
-
-    # All the special cirucmstances
-    # where a player moves twice are handled by spell cards
-    # so this logic will do for now
-    return LPST->P2 if $apl eq LPST->P1;
-    return LPST->P1;
-}
-
-sub f1($$){
-    my ($b, $ns0) = (shift, shift);
-    my $apl;
-    my $tc;
-
-    $apl = LPST->P1;
-
-    $tc = 0;
-    
-    for my $s0 (split(/\n/, $ns0)){
-	mt2($b, $s0, $tc, $apl);
-	
-	$apl = f2($s0, $tc, $apl);
-	# printf(">>%s\n", $s0);
-	$tc++;
-    }
-}
-
-my $ns0;
-
-$ns0 = "";
-$ns0 .= "A I It Au N\n";
-$ns0 .= "A S Im Rc It\n";
-
-my $m1 = "C10";
-my $m2 = "B3";
-my $c1 = LPST->MG_SY;
-my $c2 = LPST->MG_A;
-
-my $b;
-
-$b = LPST->new();
-
-f1($b, $ns0);
-
-# theres a problem here
-# with 2 character piece names
-# and parsing...
-$b->summon("Ak10*", "P1");
-
-# $board{$m1} = $P1.$DIV.$c1;
-# $board{$m2} = $P2.$DIV.$c2;
-
-# $b->shade_all_p1_mvmt();
-$b->disp_board();

.gitignore

@@ -2,3 +2,4 @@
 p[0-9].pl
 p[0-9][0-9].pl
 notes.txt
+#*

LPST.pm

@@ -8,6 +8,7 @@ use utf8;
 my $ARRAY = "ARRAY";
 
 my $HAND_SIZE = 5;
+my $MAX_FT_SUMMON  = 16;
 
 my $X_BOX_CHR = chr(0x2573);
 my $GRAY_BOX_CHR = chr(0x2591);
@@ -392,7 +393,8 @@ sub apply_shade($$){
     my $not = shift;
     my $en = shift;
 
-    $sc{$not} = $en unless (grep /^$not$/, keys(%sc));
+    $sc{$not} = $en unless grep(/^$not$/, keys(%sc));
+    $sc{$not} = $MOVBLOCK_ENUM unless $sc{$not} == $en;
 }
 
 sub get_shade_en($){
@@ -740,6 +742,7 @@ sub check_valid_cell($){
     die "invalid cell - $hx1" unless grep {
 	$hx1 =~ /^$_$/i
     } keys %board;
+    die "piece in cell $hx1" if $board{$hx1} ne $EMPTY_CELL;
 }
 
 sub check_valid_player($){
@@ -760,8 +763,8 @@ sub check_sz($$){
     my ($hx1, $apl) = (shift, shift);
     my ($c0, $r0) = cell_index($hx1);
 
-    die "not in start zone" if($r0 > 3 && $apl eq $P1);
-    die "not in start zone" if($r0 < 8 && $apl eq $P2);
+    die "$hx1 not in start zone" if($r0 > 3 && $apl eq $P1);
+    die "$hx1 not in start zone" if($r0 < 8 && $apl eq $P2);
 }
 
 sub draw($$){
@@ -785,6 +788,7 @@ sub summon($$$){
     check_block($hx1, $apl);
     $board{uc $hx1} = $apl.$DIV.$pi;
 }
+
 sub sz_summon($$$){
     my ($self, $s0, $apl) = (shift, shift, shift);
     my ($pi, $hx1) = $s0 =~ /([A-Za-z]{1,2})([A-Za-z][0-9]{1,})/;
@@ -793,6 +797,17 @@ sub sz_summon($$$){
     summon($self, $s0, $apl);
 }
 
+sub ft_summon($$$){
+    my ($self, $s0, $apl) = (shift, shift, shift);
+    die "Must summon queen on first turn" unless $s0 =~ /$MG_Q[A-ka-k]{1,2}[0-9]{1,2}/;
+    die "Max summons on first turn is $MAX_FT_SUMMON" if ( scalar (() = $s0 =~ /\*/g) > $MAX_FT_SUMMON );
+
+    for my $mv1 ($s0 =~ /[A-Za-z]{2,3}[0-9]{1,2}\*/g){
+	sz_summon($self, $mv1, $apl);
+	# printf("%s\n", $mv1);
+    }
+}
+
 sub new {
     my $class = shift;
     my $self = { @_ };

ntvl.pl

@@ -14,7 +14,8 @@ my $MOVE      = 0b00000010;
 my $CAPTURE   = 0b00000100;
 my $SACRIFICE = 0b00001000;
 # my $SPELL     = 0b10000000;
-my $DRAW      = 0b01000000;
+my $DRAW      = 0b00010000;
+my $FT        = 0b00100001;
 
 sub is_summon($){
    return $_[0] =~ /\*/ ? $SUMMON : 0;
@@ -36,6 +37,16 @@ sub is_draw($){
     return $_[0]  <= 1 ? $DRAW : 0;
 }
 
+sub is_ft($){
+    return $_[0]  <= 3 && $_[0] > 1? $FT : 0;
+}
+
+sub ft($$$){
+    my ($b, $s0, $apl) = (shift, shift, shift);
+    die "invalid ft() syntax $s0" unless $s0 =~ /^([A-Za-z]{2,3}[0-9]{1,2}\*){1,}$/;
+    $b->ft_summon($s0, $apl);
+}
+
 sub draw($$$){
     my ($b, $s0, $apl) = (shift, shift, shift);
     die "invalid draw() syntax $s0" unless $s0 =~ /^([A-Za-z]{1,2} ){4}[A-Za-z]{1,2}$/;
@@ -50,6 +61,7 @@ sub mt2($$$$){
     # return $SACRIFICE if $s0 =~ /([A-Za-z]{1,2}[0-9]{1,2}' ?){2}/;
     # return $DRAW if $tc <= 1;
 
+    ft($b, $s0, $apl) if is_ft($tc);
     draw($b, $s0, $apl) if is_draw($tc);
 }
 
@@ -95,9 +107,11 @@ my $ns0;
 $ns0 = "";
 $ns0 .= "A I It Au N\n";
 $ns0 .= "A S Im Rc It\n";
+# $ns0 .= "Aa1*Ab1*Ac1*Ad1*Ae1*Qf1*Ag1*Ah1*Ai1*Aj1*Ak1*Ad2*Ai2*Aj2*Ak2*Ad3*\n";
+$ns0 .= "Aa1*Ab1*Ac1*Ad1*Ae1*Qf1*\n";
 
-my $m1 = "C10";
-my $m2 = "B3";
+my $m1 = "c10";
+my $m2 = "b3";
 my $c1 = LPST->MG_SY;
 my $c2 = LPST->MG_A;
 
@@ -107,12 +121,5 @@ $b = LPST->new();
 
 f1($b, $ns0);
 
-$b->summon("Ak10*", "P1");
-
-$b->sz_summon("Ak3*", "P1");
-
-# $board{$m1} = $P1.$DIV.$c1;
-# $board{$m2} = $P2.$DIV.$c2;
-
-# $b->shade_all_p1_mvmt();
-# $b->disp_board();
+$b->shade_all_p1_mvmt();
+$b->disp_board();