From bf3780651505a4a9299498ca84ef94e664605229 Mon Sep 17 00:00:00 2001 From: gashapwn Date: Sat, 10 Apr 2021 02:07:40 +0000 Subject: [PATCH] LPST.pm - first turn summons ntvl.pl - updated test cases --- #ntvl.pl# | 119 ------------------------------------------------------------- .gitignore | 1 + LPST.pm | 21 +++++++++-- ntvl.pl | 31 +++++++++------- 4 files changed, 38 insertions(+), 134 deletions(-) delete mode 100644 #ntvl.pl# diff --git a/#ntvl.pl# b/#ntvl.pl# deleted file mode 100644 index ddc0fcf..0000000 --- a/#ntvl.pl# +++ /dev/null @@ -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(); diff --git a/.gitignore b/.gitignore index b9b1fd6..dc11994 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ p[0-9].pl p[0-9][0-9].pl notes.txt +#* \ No newline at end of file diff --git a/LPST.pm b/LPST.pm index 77a2381..bc52fb4 100644 --- a/LPST.pm +++ b/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 = { @_ }; diff --git a/ntvl.pl b/ntvl.pl index 6cbb368..4d531e4 100644 --- a/ntvl.pl +++ b/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();