LPST.pm - added mirror move. was a massive pain ntvl.pl updated test cases

LPST.pm

@@ -393,6 +393,7 @@ sub apply_shade($$){
     my $not = shift;
     my $en = shift;
 
+    # $sc{$not} = $en;
     $sc{$not} = $en unless grep(/^$not$/, keys(%sc));
     $sc{$not} = $MOVBLOCK_ENUM unless $sc{$not} == $en;
 }
@@ -622,12 +623,12 @@ sub apply_shift($$){
     my $r0;
     my $c0;
 
-    ($r0, $c0) = cell_index($not);
+    ($c0, $r0) = cell_index($not);
 
-    $r0 += $my_shift->[0];
-    $c0 += $my_shift->[1];
+    $r0 += $my_shift->[1];
+    $c0 += $my_shift->[0];
     return $ERR_C_1 if $r0 > 11 or $c0 > 11 or $r0 < 1 or $c0 < 1;
-    return cell_index_rev($r0, $c0);
+    return cell_index_rev($c0, $r0);
 }
 
 sub calc_new_cell($$){
@@ -655,8 +656,17 @@ sub calc_new_cell($$){
     return apply_shift($not, [$x_shift, $y_shift]);
 }
 
-sub get_mov($$){
-    my ($pi, $en) = (shift, shift);
+sub mirror_mov($){
+    my $mov = shift;
+    
+    return MoveStruct->new(
+	"mov" => [$mov->{"mov"}[0] * -1, $mov->{"mov"}[1] * -1],
+	"type" => $mov->{"type"}
+	);
+}
+
+sub get_mov($$$){
+    my ($pi, $en, $apl) = (shift, shift, shift);
 
     my @mv1;
 
@@ -664,6 +674,13 @@ sub get_mov($$){
 	($_->{"type"} & $en) != 0
     } @{$MOVE{$pi}};
 
+    my ($t1, $t2) = (0, 0);
+    if($apl eq $P2){
+	@mv1 = map {
+	    mirror_mov($_)
+	} @mv1;
+    }
+
     return \@mv1;
 }
 
@@ -671,9 +688,11 @@ sub find_all_mov($$){
     my ($not, $en) = (shift, shift);
     my $pi;
     my @mv1;
+    my $apl;
 
     $pi = cell_pi($not);
-    @mv1 = @{ get_mov($pi, $en) };
+    $apl = cell_pl($not);
+    @mv1 = @{ get_mov($pi, $en, $apl) };
 
     return grep {
 	$_ if $_->[0] ne $ERR_C_1
@@ -689,9 +708,11 @@ sub shade_pi_mvmt($$){
     my ($not, $en) = (shift, shift);
     my $c1;
     my @mv1;
-    
+
     @mv1 = find_all_mov($not, $en);
+    # printf("%d\n", scalar @mv1);
     for my $mv (@mv1){
+	# printf(">>%s\n", $mv->[0]);
 	apply_shade($mv->[0], $mv->[1]);
     }
 }
@@ -700,21 +721,25 @@ sub shade_all_mvmt($$){
     my ($pl, $en) = (shift, shift);
     my @pi1;
     
-    # $pl = shift;
-
     @pi1 = grep {
 	cell_pl($_) eq $pl
     } keys(%board);
 
     for my $el (@pi1){
+	# printf("%s\n", $el);
 	shade_pi_mvmt($el, $en);
     }
+    # die "test 0";
 }
 
 sub shade_all_p1_mvmt($){
     shade_all_mvmt($P1, $MOVBLOCK_ENUM);
 }
 
+sub shade_all_p2_mvmt($){
+    shade_all_mvmt($P2, $MOVBLOCK_ENUM);
+}
+
 sub get_block_cell($){
     my $pl;
 
@@ -731,7 +756,7 @@ sub get_block_cell($){
 
 sub check_valid_card($){
     my $s1 = shift;
-    die "invalid card - $s1" unless grep {
+    die "invalid card/piece - $s1" unless grep {
 	$_ =~ /^$s1$/i
     } @MG_PI;
 }
@@ -752,6 +777,14 @@ sub check_valid_player($){
     } keys %HAND;
 }
 
+sub check_valid_piece($$){
+    my ($pi, $apl) = (shift, shift);
+    check_valid_card($pi);
+    die "player $apl does not have $pi" unless grep {
+	$pi =~ /$_$/
+    } @{$HAND{$apl}};
+}
+
 sub check_block($$){
     my ($s0, $apl) = (shift, shift);
     for my $c0 (get_block_cell($OPPL{$apl})){
@@ -785,6 +818,7 @@ sub summon($$$){
     $hx1 = uc $hx1;
     check_valid_cell($hx1);
     check_valid_player($apl);
+    check_valid_piece($pi, $apl);
     check_block($hx1, $apl);
     $board{uc $hx1} = $apl.$DIV.$pi;
 }
@@ -802,7 +836,7 @@ sub ft_summon($$$){
     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){
+    for my $mv1 ($s0 =~ /\b[A-Za-z]{2,3}[0-9]{1,2}\*/g){
 	sz_summon($self, $mv1, $apl);
 	# printf("%s\n", $mv1);
     }
@@ -824,6 +858,12 @@ sub new {
 	$AXIS_RV{$_}
     }(1...11);
 
+    # Both players start with a
+    # queen
+    push(@{$HAND{$P1}}, "Q");
+    push(@{$HAND{$P2}}, "Q");
+    
+
     return bless $self, $class;
 }
 

ntvl.pl

@@ -43,7 +43,7 @@ sub is_ft($){
 
 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,}$/;
+    die "invalid ft() syntax $s0" unless $s0 =~ /^([A-Za-z]{2,3}[0-9]{1,2}\*(, )?){1,}$/;
     $b->ft_summon($s0, $apl);
 }
 
@@ -105,15 +105,10 @@ sub f1($$){
 my $ns0;
 
 $ns0 = "";
-$ns0 .= "A I It Au N\n";
+$ns0 .= "A I Im Au H\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 $c1 = LPST->MG_SY;
-my $c2 = LPST->MG_A;
+$ns0 .= "Aa1*, Ab1*, Ac1*, Ad1*, Ae1*, Qf1*, Ag1*, Ah1*, Ai1*, Aj1*, Ak1*, Ad2*, Ai2*, Aj2*, Ak2*, Ad3*\n";
+$ns0 .= "Aa11*, Ab11*, Ac11*, Ad11*, Ae11*, Qf11*\n";
 
 my $b;
 
@@ -121,5 +116,5 @@ $b = LPST->new();
 
 f1($b, $ns0);
 
-$b->shade_all_p1_mvmt();
+$b->shade_all_p2_mvmt();
 $b->disp_board();