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

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

Browse Source
This commit is contained in:
gashapwn 2021-04-10 02:07:40 +00:00
parent 9f4d008df5
commit bf37806515
4 changed files with 38 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
#ntvl.pl#
View File

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

1
.gitignore vendored
View File

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

21
LPST.pm
View File

@ -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 = { @_ };

31
ntvl.pl
View File

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