gashapwn/lpst
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

LPST.pm - added move() ntvl.pl - updated test cases

Browse Source
This commit is contained in:
gashapwn 2021-04-11 21:56:47 +00:00
parent 74316a8618
commit 6276952ec3
2 changed files with 66 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
LPST.pm
View File

@ -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;
}

22
ntvl.pl
View File

@ -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;