LPST.pm - added summons ntvl.pl - updated test cases

#ntvl.pl#

@@ -0,0 +1,119 @@
+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();

LPST.pm

@@ -82,6 +82,11 @@ my @MG_PI = (
 my $P1 = "P1";
 my $P2 = "P2";
 
+my %OPPL = (
+    $P1 => $P2,
+    $P2 => $P1
+    );
+
 my %HAND = (
     $P1 => [],
     $P2 => []
@@ -722,20 +727,72 @@ sub get_block_cell($){
     } keys(%board);
 }
 
+sub check_valid_card($){
+    my $s1 = shift;
+    die "invalid card - $s1" unless grep {
+	$_ =~ /^$s1$/i
+    } @MG_PI;
+}
+
+sub check_valid_cell($){
+    my $hx1 = shift;
+
+    die "invalid cell - $hx1" unless grep {
+	$hx1 =~ /^$_$/i
+    } keys %board;
+}
+
+sub check_valid_player($){
+    my $apl = shift;
+    die "invalid player - $apl" unless grep {
+	$apl =~ /^$_$/
+    } keys %HAND;
+}
+
+sub check_block($$){
+    my ($s0, $apl) = (shift, shift);
+    for my $c0 (get_block_cell($OPPL{$apl})){
+	die "summon to cell $s0 is blocked" if $s0 eq $c0;
+    }
+}
+
+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);
+}
+
 sub draw($$){
-    my ($self, $s0, $apt) = (shift, shift, shift);
+    my ($self, $s0, $apl) = (shift, shift, shift);
 
     my $i = 0;
     for my $s1 (uniq( [split(/ /, $s0)] )){
 	$i++;
-	die "invalid card - $s1" unless grep {
+	check_valid_card($s1);
-	    $_ =~ /^$s1$/
+	push(@{$HAND{$apl}}, $s1);
-	} @MG_PI;
-	$HAND{$P1} = $s1;
     }
     die "draw() $s0 - hand size less than $HAND_SIZE. Possible duplicate card?" if $i < $HAND_SIZE;
 }
 
+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_valid_player($apl);
+    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,})/;
+    $hx1 = uc $hx1;
+    check_sz($hx1, $apl);
+    summon($self, $s0, $apl);
+}
+
 sub new {
     my $class = shift;
     my $self = { @_ };
@@ -760,7 +817,6 @@ sub uniq($){
     return grep { !$h0{$_}++ } @{$_[0]};
 }
 
-
 sub P1 {
     return $P1;
 }

ntvl.pl

@@ -107,6 +107,10 @@ $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;