|
- #!/usr/bin/perl
-
- use warnings;
- use strict;
-
- use utf8;
-
- my $X_BOX_CHR = chr(0x2573);
- my $GRAY_BOX_CHR = chr(0x2591);
- my $ALT_US = chr(0x2017);
- my $ALT_PIPE = chr(0x2016);
-
- my $SHADE_1_CHR = $GRAY_BOX_CHR;
- my $SHADE_2_CHR = $X_BOX_CHR;
-
- my $PAD_AXIS = " ";
- my $PAD_EVEN = " ";
- my $PAD_ODD = " ";
-
- my $HEX_1 = '-/--\-';
- my $HEX_2 = '| __ |';
- my $HEX_3 = '| |';
-
- my $HEX_S1_1 = '-/--\-';
- my $HEX_S1_2 = sprintf("|%s%s%s%s|", $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR);
- my $HEX_S1_3 = sprintf("|%s%s%s%s|", $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR, $SHADE_1_CHR);
-
- my $HEX_S2_1 = '-/--\-';
- my $HEX_S2_2 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR);
- my $HEX_S2_3 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_2_CHR);
-
- my $HEX_S3_1 = '-/--\-';
- my $HEX_S3_2 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_1_CHR, $SHADE_1_CHR);
- my $HEX_S3_3 = sprintf("|%s%s%s%s|", $SHADE_2_CHR, $SHADE_2_CHR, $SHADE_1_CHR, $SHADE_1_CHR);
-
- my $HL_1 = "|____ ";
- my $HL_2 = $ALT_PIPE.$ALT_US.$ALT_US.$ALT_US.$ALT_US." ";
-
- my $SUB_CHR = "_";
- my $ALT_SUB_CHR = "=";
-
- my $BLANK_CELL_CHR = $ALT_US;
-
- my $PREF_1 = substr($HEX_1, -2, 2);
- my $PREF_2 = ' ';
- my $PREF_3 = ' ';
-
- my $TRAIL_1 = substr($HEX_1, 0, 1);
- my $TRAIL_2 = substr($HEX_1, -1, 1);
- my $TRAIL_3 = substr($HEX_1, 0, 2);
-
- # Pieces
- my $MG_A = "A"; # Apprentice
- my $MG_I = "I"; # Iron Maiden
- my $MG_N = "N"; # Nekomata
- my $MG_IT = "It"; # Ittan-Momen
- my $MG_H = "H"; # Harpy
- my $MG_S = "S"; # Slime
- my $MG_RC = "Rc"; # Redcap
- my $MG_HS = "Hs"; # Holstaur
- my $MG_RO = "Ro"; # Red Oni
- my $MG_B = "B"; # Blue Oni
- my $MG_P = "P"; # Preistess
- my $MG_IM = "Im"; # Imp
- my $MG_F = "F"; # False Angel
- my $MG_QS = "Qs"; # Queen slime
- my $MG_AU = "Au"; # Automaton
- my $MG_SY = "Sy"; # Sylph
- my $MG_Q = "Q"; # Queen
-
- # Players
- my $P1 = "P1";
- my $P2 = "P2";
-
- my $DIV = ":";
-
- my %AXIS = (
- "A" => 1,
- "B" => 2,
- "C" => 3,
- "D" => 4,
- "E" => 5,
- "F" => 6,
- "G" => 7,
- "H" => 8,
- "I" => 9,
- "J" => 10,
- "K" => 11
- );
- my %AXIS_RV = map {
- $AXIS{$_} => $_
- } keys(%AXIS);
-
-
- #
- # /--\ +1
- # | __ |
- # | |+1
- # \--/
- # -1 -1
- #
-
- # ODD
- # UP: 0, +1
- # DOWN: -1, -1
-
- # EVEN
- # UP: +1, +1
- # DOWN: +0, -1
-
- # [Row move, Diag move]
-
- my %MOVE = (
- $MG_A => [
- [-1, 1], [ 0, 1]
- ],
- $MG_Q => [
- [ 0, 1], [ 1, 0], [-1, 0], [ 0,-1],
- ],
- $MG_I => [
- [0,0]
- ],
- $MG_IT => [
- [ 0,-1], [ 1,-1]
- ],
- $MG_N => [
- [-1, 2],
- [ 1,-2]
- ],
- $MG_H => [
- [-3, 2], [-1,-2], [ 1, 2], [ 3,-2]
- ],
- $MG_RC => [
- [-1, 0], [-2, 0], [ 1, 0], [ 2, 0]
- ],
- $MG_S => [
- [-1, 1], [-2, 2], [ 0, 1], [ 0, 2],
- [ 0,-1], [ 0,-2], [ 1,-1], [ 2,-2],
- ],
- $MG_HS => [
- [-3, 1], [-2,-1], [ 2, 1], [ 3,-1]
- ],
- $MG_RO => [
- [-1, 1], [ 0, 1], [ 1, 1], [ 1,-2]
- ],
- $MG_B => [
- [-1, 1], [ 0, 1], [ 0,-2], [ 2,-2]
- ],
- $MG_P => [
- [-4, 2], [-2, 1], [-2,-2], [-1,-1],
- [ 1, 1], [ 2,-1], [ 2, 2], [ 4,-2]
- ],
- $MG_IM => [
- [-2, 1], [-1,-1], [-1, 2], [ 1, 1],
- [ 1,-1], [ 2,-1]
- ],
- $MG_F => [
- [-1, 0], [-1, 1], [ 0, 1], [ 0,-1],
- [ 1, 0], [ 1,-1]
- ],
- $MG_QS => [
- [-3, 3], [-2, 2], [-2, 0], [-1, 0],
- [-1, 1], [ 0, 1], [ 0, 2], [ 0, 3],
- [ 0,-1], [ 0,-2], [ 0,-3], [ 1, 0],
- [ 1,-1], [ 2, 0], [ 2,-2], [ 3,-3],
- ],
- $MG_AU => [
- [-1, 0], [-1, 1], [ 0, 1], [ 0,-1],
- [ 1, 0], [ 1,-1]
- ],
- $MG_SY => [
- [-4, 4], [-3, 3], [-3, 2], [-1,-2],
- [ 0,-4], [ 0,-3], [ 0, 3], [ 0, 4],
- [ 1, 2], [ 3,-2], [ 3,-3], [ 4,-4]
- ]
- );
-
- my %BLOCK = (
- );
-
- # Special cells
- my $EMPTY_CELL = "_";
-
- # Shade enum
- my $SHADE_3_ENUM = 3;
- my $SHADE_2_ENUM = 2;
- my $SHADE_1_ENUM = 1;
- my $EMPTY_ENUM = 0;
-
- my %SHADE = (
- $SHADE_1_ENUM => [$HEX_S1_1, $HEX_S1_2, $HEX_S1_3],
- $SHADE_2_ENUM => [$HEX_S2_1, $HEX_S2_2, $HEX_S2_3],
- $SHADE_3_ENUM => [$HEX_S3_1, $HEX_S3_2, $HEX_S3_3],
- $EMPTY_ENUM => [$HEX_1, $HEX_2, $HEX_3]
- );
-
- my $ERR_C_1 = -1;
-
- my %sc = ();
- my %board;
-
- # Display pieces
- #==================================================
-
- # I hate this function
- sub f_1($$$){
- my $p = shift;
- my $c0 = shift;
- my $hex = shift;
- my $s0;
-
- $p =~ s/($P1|$P2)$DIV//;
- $p .= "_" if length($p) < 2;
- $s0 = $hex;
-
- $s0 =~ s/$SUB_CHR{1,2}/$p/;
-
- unless($p eq "__"){
- substr($s0, 2,2) = $p;
- }
-
- if($c0 % 2 == 0){
- $s0 =~ s/$SUB_CHR/$BLANK_CELL_CHR/g;
- }
-
- return $s0;
- }
-
- # Display shade
- #==================================================
-
- sub shade_cell($$){
- my $not = shift;
- my $en = shift;
-
- $sc{$not} = $en unless (grep /^$not$/, keys(%sc));
- }
-
- sub shade_t($){
- my $not = shift;
- return $sc{$not} if (grep /^$not$/, keys(%sc));
- return $EMPTY_ENUM;
- }
-
- sub get_shade_chr($){
- my $en = shift;
- return $SHADE{$en};
- }
-
- sub shade_lookup($$){
- my ($r0, $c0) = (shift, shift);
- my $not;
-
- $not = cell_index_rev($c0, $r0);
- return get_shade_chr(shade_t($not));
- }
-
-
-
-
- # Display lines
- #==================================================
-
- sub disp_1($$){
- my ($r0, $c0) = (shift, shift);
- my $hex;
-
- $hex = shade_lookup($r0, $c0)->[0];
-
- return $hex;
- # return $HEX_1;
- }
-
- sub disp_2($$){
- my ($r0, $c0) = (shift, shift);
- my $p;
- my $not;
- my $hex;
-
- $hex = shade_lookup($r0, $c0)->[1];
- $not = cell_index_rev($c0, $r0);
-
- $p = $board{$not};
-
- return f_1($p, $c0, $hex);
- # my ($r0, $c0) = (shift, shift);
- # return $HEX_2;
- }
-
- sub disp_3($$){
- my ($r0, $c0) = (shift, shift);
- my $hex;
-
- $hex = shade_lookup($r0, $c0)->[2];
-
- return $hex;
- }
-
- sub disp_y_axis($$$$){
- my ($s0, $s1, $s2, $r0) = @_;
- my $n0;
-
- $n0 = length($r0);
-
- $s0 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_1;
- $s1 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_2;
- $s1 =~ s/^ {$n0}/$r0/;
- $s2 = $r0 % 2 == 1 ? $PAD_ODD : $PAD_EVEN.$PREF_3;
-
- return ($s0, $s1, $s2);
- }
-
- # Display cell
- #==================================================
-
- sub add_cell($$$$$){
- my ($s0, $s1, $s2, $r0, $c0) = @_;
-
- $s0 .= disp_1($r0, $c0);
- $s1 .= disp_2($r0, $c0);
- $s2 .= disp_3($r0, $c0);
-
- return ($s0, $s1, $s2);
- }
-
- sub disp_0($){
- my $r0;
-
- my ($s0, $s1, $s2);
-
- $r0 = shift;
-
- # Append the y axis
- ($s0, $s1, $s2) = disp_y_axis($s0, $s1, $s2, $r0);
-
- # Iterate through the cells
- for my $i (1..11){
- ($s0, $s1, $s2) = add_cell($s0, $s1, $s2, $r0, $i);
- }
-
- return $s0."\n".$s1."\n".$s2."\n";
- }
-
- # Display row
- #==================================================
-
- sub disp_row($){
- my $row;
- my $r0;
-
- $r0 = shift;
-
- $row = disp_0($r0);
-
- # Handle trailing characters
- if($r0 % 2 == 1){
- # Trim the start of the first line
- $row =~ s/$TRAIL_1/ /;
- # Trim the end of the first line
- $row =~ s/\n/$TRAIL_3\n/
- }else{
- # Trim the end of the last line
- $row =~ s/$TRAIL_2\n/ \n/m;
- }
-
- return $row;
- }
-
- sub disp_trailing_row(){
- my $s0;
- my $s1;
-
- $s0 = $PAD_EVEN.$PREF_1;
-
- # Clear some chars from
- # our hex patterns
- $s1 = $HEX_1;
- substr($s1, 2,2) = " ";
-
- # Append hex pattern to
- # trailing row
- for my $i (1..11){
- $s0 .= $s1;
- }
- # Clear one last pair of
- # chrs
- substr($s0, -2,2) = " ";
- $s0 .= "\n";
-
- return $s0;
- }
-
- sub disp_x_axis(){
- my $s0;
-
- $s0 = $PAD_AXIS;
- $s0 .= join(
- $PAD_AXIS, map{
- $AXIS_RV{$_}
- }(1..11));
- $s0 .= "\n";
-
- $s0 .= $PAD_AXIS;
- $s0 .= join(
- "", map{
- $_ % 2 == 1 ? $HL_1 : $HL_2
- }(1..11));
- $s0 .= "\n";
-
- return $s0
- }
-
- # Display board
- #==================================================
-
- sub disp_board(){
- my $b;
-
- for my $i (map {11-$_+1} (1..11)) {
- $b .= disp_row($i);
- }
- $b .= disp_trailing_row();
- $b .= disp_x_axis();
- $b =~ s/$TRAIL_1$TRAIL_3\n/\n/m;
-
- for my $i (1..11-1){
- substr($b, 2+6*$i, 2) = " ";
- }
- printf("%s", $b);
- }
-
-
-
-
- # Caclulate movement
- #==================================================
- sub cell_pi($){
- my $not = shift;
- return (split(/$DIV/, $board{$not}))[1]
- }
-
- sub cell_pl($){
- my $not = shift;
- return (split(/$DIV/, $board{$not}))[0]
- }
-
- sub cell_index_rev($$){
- return $AXIS_RV{$_[0]}.$_[1];
- }
-
- sub cell_index($){
- my ($chr1, $chr2) = (split(//, $_[0]));
- return ($AXIS{$chr1}, $chr2);
- }
-
- sub apply_shift($$){
- my ($not, $my_shift) = (shift, shift);
- my $r0;
- my $c0;
-
- ($r0, $c0) = cell_index($not);
-
- $r0 += $my_shift->[0];
- $c0 += $my_shift->[1];
- # die "cell index [$r0, $c0]: out of bound exception" if $r0 > 11 or $c0 > 11 or $r0 < 1 or $c0 < 1;
- return $ERR_C_1 if $r0 > 11 or $c0 > 11 or $r0 < 1 or $c0 < 1;
- return cell_index_rev($r0, $c0);
- }
-
- sub calc_move($$){
- my ($not, $mov) = (shift, shift);
- my $r0;
- my $c0;
-
- my $x_shift;
- my $y_shift;
-
- my $n0;
- my $ni;
-
- ($c0, $r0) = cell_index($not);
-
- # get y_shift
- $y_shift = $mov->[1];
-
- # get x_shift
- $x_shift = $mov->[0];
-
- # make x_shift adjustment
-
- $ni = $y_shift != 0 ? ($y_shift / abs($y_shift)) : 1;
- # $ni *= -1;
-
- # moving down: $ni == -1 want value of 0
- # moving up: $ni == +1 want value of 1
- $n0 = ($r0 + (($ni + 1)/2) ) % 2;
- $x_shift += int(($y_shift + ($n0 * $ni)) / 2);
-
- return apply_shift($not, [$x_shift, $y_shift]);
- }
-
-
-
- sub shade_move($){
- my $not = shift;
- my $c1;
- my @mv1;
- my @mv2;
-
- $c1 = cell_pi($not);
-
- @mv1 = @{$MOVE{$c1}};
- @mv2 = grep {
- $_ ne $ERR_C_1
- } map {
- calc_move($not, $_)
- } @mv1;
-
- for my $mv (@mv2){
- shade_cell($mv, $SHADE_1_ENUM);
- }
- }
-
- # Main starts here!
- binmode(STDOUT, ":utf8");
-
- # Creates a hash of the the form
- # $board{cell_notation} = piece_enum
- %board = map {
- $_ => $EMPTY_CELL
- } map {
- my $l0;
- $l0 = $_;
- (map {$l0.$_} ("1".."11"))
- } map {
- $AXIS_RV{$_}
- }(1...11);
-
- # my $m1 = "F7";
- my $m1 = "A1";
- my $c1 = $MG_QS;
-
- $board{$m1} = $P1.$DIV.$c1;
- shade_move($m1);
-
- disp_board();
-
-
-
|