From 6276952ec311536833bab34932914a8c874ec70a Mon Sep 17 00:00:00 2001
From: gashapwn <gashapwn@tildezero.lan>
Date: Sun, 11 Apr 2021 21:56:47 +0000
Subject: [PATCH] LPST.pm - added move()  ntvl.pl - updated test cases

---
 LPST.pm | 54 ++++++++++++++++++++++++++++++++++++++++++++++--------
 ntvl.pl | 22 ++++++++++++++++++++--
 2 files changed, 66 insertions(+), 10 deletions(-)

diff --git a/LPST.pm b/LPST.pm
index 86f7843..d77325c 100644
--- a/LPST.pm
+++ b/LPST.pm
@@ -710,9 +710,7 @@ sub shade_pi_mvmt($$){
     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]);
     }
 }
@@ -726,7 +724,6 @@ sub shade_all_mvmt($$){
     } keys(%board);
 
     for my $el (@pi1){
-	# printf("%s\n", $el);
 	shade_pi_mvmt($el, $en);
     }
     # die "test 0";
@@ -761,13 +758,37 @@ sub check_valid_card($){
     } @MG_PI;
 }
 
+sub check_empty_cell($){
+    my $hx1 = shift;
+    $hx1 = uc $hx1;
+
+    check_valid_cell($hx1);
+    die "piece in cell $hx1" if $board{$hx1} ne $EMPTY_CELL;    
+}
+
+sub check_nonempty_cell($){
+    my $hx1 = shift;
+    $hx1 = uc $hx1;
+
+    check_valid_cell($hx1);
+    die "no piece in cell $hx1" if $board{$hx1} eq $EMPTY_CELL;
+}
+
 sub check_valid_cell($){
     my $hx1 = shift;
-
+    $hx1 = uc $hx1;
+    
     die "invalid cell - $hx1" unless grep {
 	$hx1 =~ /^$_$/i
     } keys %board;
-    die "piece in cell $hx1" if $board{$hx1} ne $EMPTY_CELL;
+}
+
+sub check_src_cell($$){
+    my ($hx1, $apl) = (shift, shift);
+    $hx1 = uc $hx1;
+
+    check_nonempty_cell($hx1);
+    die "This cell is not owned by $apl" if cell_pl($hx1) ne $apl;
 }
 
 sub check_valid_player($){
@@ -792,6 +813,12 @@ sub check_block($$){
     }
 }
 
+sub check_valid_mov($$){
+    my ($src, $dst) = (shift, shift);
+    $src = uc $src;
+    die "not valid move" unless grep {$dst eq $_->[0]} find_all_mov($src, $MOVE_ENUM);
+}
+
 sub check_sz($$){
     my ($hx1, $apl) = (shift, shift);
     my ($c0, $r0) = cell_index($hx1);
@@ -816,7 +843,7 @@ sub summon($$$){
     my ($self, $s0, $apl) = (shift, shift, shift);
     my ($pi, $hx1) = $s0 =~ /([A-Za-z]{1,2})([A-Za-z][0-9]{1,})/;
     $hx1 = uc $hx1;
-    check_valid_cell($hx1);
+    check_empty_cell($hx1);
     check_valid_player($apl);
     check_valid_piece($pi, $apl);
     check_block($hx1, $apl);
@@ -838,10 +865,22 @@ sub ft_summon($$$){
 
     for my $mv1 ($s0 =~ /\b[A-Za-z]{2,3}[0-9]{1,2}\*/g){
 	sz_summon($self, $mv1, $apl);
-	# printf("%s\n", $mv1);
     }
 }
 
+sub mov($$$){
+    my ($self, $s0, $apl) = (shift, shift, shift);
+    my ($src, $dst) = $s0 =~ /([A-Za-z][0-9]{1,2})([A-Za-z][0-9]{1,2})$/;
+    $src = uc $src;
+    $dst = uc $dst;
+    check_valid_player($apl);
+    check_src_cell($src, $apl);
+    check_empty_cell($dst);
+    check_valid_mov($src, $dst);
+    $board{$dst} = cell_pl($src).$DIV.cell_pi($src);
+    $board{$src} = $EMPTY_CELL;
+}
+
 sub new {
     my $class = shift;
     my $self = { @_ };
@@ -862,7 +901,6 @@ sub new {
     # queen
     push(@{$HAND{$P1}}, "Q");
     push(@{$HAND{$P2}}, "Q");
-    
 
     return bless $self, $class;
 }
diff --git a/ntvl.pl b/ntvl.pl
index b412ef4..f8d16b0 100644
--- a/ntvl.pl
+++ b/ntvl.pl
@@ -41,6 +41,12 @@ sub is_ft($){
     return $_[0]  <= 3 && $_[0] > 1? $FT : 0;
 }
 
+sub mov($$$){
+    my ($b, $s0, $apl) = (shift, shift, shift);
+    die "invalid mov() syntax $s0" unless $s0 =~ /^[A-Za-z]{1,2}([A-Za-z][0-9]{1,2}){2}$/;
+    $b->mov($s0, $apl);
+}
+
 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,}$/;
@@ -60,9 +66,11 @@ sub mt2($$$$){
     # return $CAPTURE if $s0 =~ /\~/;
     # return $SACRIFICE if $s0 =~ /([A-Za-z]{1,2}[0-9]{1,2}' ?){2}/;
     # return $DRAW if $tc <= 1;
+    return mov($b, $s0, $apl) if is_move($s0);
+    return ft($b, $s0, $apl) if is_ft($tc);
+    return draw($b, $s0, $apl) if is_draw($tc);
 
-    ft($b, $s0, $apl) if is_ft($tc);
-    draw($b, $s0, $apl) if is_draw($tc);
+    die "invalid syntax at \$tc: $tc - $s0";
 }
 
 sub mt1($$$){
@@ -109,6 +117,16 @@ $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 .= "Aa11*, Ab11*, Ac11*, Ad11*, Ae11*, Qf11*\n";
+$ns0 .= "Aa1a2\n";
+$ns0 .= "Qf11g11\n";
+$ns0 .= "Aa2a3\n";
+$ns0 .= "Qg11f10\n";
+$ns0 .= "Aa3a4\n";
+$ns0 .= "Qf10e10\n";
+$ns0 .= "Aa4a5\n";
+$ns0 .= "Qe10d10\n";
+$ns0 .= "Aa5a6\n";
+# $ns0 .= "Qd10e9\n";
 
 my $b;