Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[lib/Druid] converted all modules block-decl -> file-decl

Less indentation needed that way. It looks better with the Pod comments.
  • Loading branch information...
commit 4eddde6a75f607abceaa0a8bb2123b113d9de73a 1 parent 8bc9c1e
@masak authored
View
34 lib/Druid/Base.pm
@@ -1,30 +1,28 @@
-use v6;
+class Druid::Base;
=begin SUMMARY
C<Druid::Base> is the base class of most other Druid classes, collecting
regexes, attributes and methods which most of these other classes need.
=end SUMMARY
-class Druid::Base {
- # RAKUDO: Cannot use dashes here. [perl #64464]
- regex col_letter { <[a..z]> }
- regex row_number { \d+ }
- regex coords { <col_letter><row_number> }
+# RAKUDO: Cannot use dashes here. [perl #64464]
+regex col_letter { <[a..z]> }
+regex row_number { \d+ }
+regex coords { <col_letter><row_number> }
- our $.sarsen-move = /^ <coords> $/;
- our $.lintel-move = /^ <coords> '-' <coords> $/;
- our $.pass = /^ ['pass' | 'p'] $/;
- our $.swap = /^ ['swap' | 's'] $/;
- our $.resign = /^ ['resign' | 'r'] $/;
+our $.sarsen-move = /^ <coords> $/;
+our $.lintel-move = /^ <coords> '-' <coords> $/;
+our $.pass = /^ ['pass' | 'p'] $/;
+our $.swap = /^ ['swap' | 's'] $/;
+our $.resign = /^ ['resign' | 'r'] $/;
- method extract-coords(Match $m) {
- # RAKUDO: Hoping these explicit int(...) conversions won't be
- # necessary in the long run.
- my Int $row = int($m<row_number> - 1);
- my Int $column = int(ord($m<col_letter>) - ord('a'));
+method extract-coords(Match $m) {
+ # RAKUDO: Hoping these explicit int(...) conversions won't be
+ # necessary in the long run.
+ my Int $row = int($m<row_number> - 1);
+ my Int $column = int(ord($m<col_letter>) - ord('a'));
- return ($row, $column);
- }
+ return ($row, $column);
}
# vim: filetype=perl6
View
445 lib/Druid/Game.pm
@@ -1,5 +1,10 @@
use v6;
+use Druid::Base;
+use Druid::Game::Subject;
+
+class Druid::Game is Druid::Base does Druid::Game::Subject;
+
=begin SUMMARY
An instance of C<Druid::Game> holds an ongoing (or finished) Druid game.
It keeps track of the contents of the board, whose turn it is, the number
@@ -13,105 +18,100 @@ instances of other classes to subscribe to updates from instances of this
class, in an B<observer> pattern.
=end SUMMARY
-use Druid::Base;
-use Druid::Game::Subject;
-
-class Druid::Game is Druid::Base does Druid::Game::Subject {
-
=attr The size of a side of the (always quadratic) board.
- has $.size;
+has $.size;
=attr An array of layers, each a C<$.size * $.size> AoA with color info.
- has @.layers;
+has @.layers;
=attr A C<$.size * $.size> AoA with height info.
- has @.heights;
+has @.heights;
=attr A C<$.size * $.size> AoA with color info.
- has @.colors;
+has @.colors;
=attr An integer (either 1 or 2) denoting whose turn it is to move.
- has $.player-to-move;
+has $.player-to-move;
=attr The number of moves made so far in the game, including swapping.
- has $.moves-so-far;
+has $.moves-so-far;
=attr Whether the game has already ended.
- has $.finished;
+has $.finished;
- has $!latest-move;
+has $!latest-move;
- # RAKUDO: This could be done with BUILD instead, as soon as BUILD can
- # access private attributes. [perl #64388]
- method new(:$size = 3) {
- die "Forbidden size: $size"
- unless 3 <= $size <= 26;
+# RAKUDO: This could be done with BUILD instead, as soon as BUILD can
+# access private attributes. [perl #64388]
+method new(:$size = 3) {
+ die "Forbidden size: $size"
+ unless 3 <= $size <= 26;
- return self.bless( self.CREATE(),
- :size($size),
- :heights(map { [ 0 xx $size ] }, ^$size),
- :colors( map { [ 0 xx $size ] }, ^$size),
- :player-to-move(1) );
- }
+ return self.bless( self.CREATE(),
+ :size($size),
+ :heights(map { [ 0 xx $size ] }, ^$size),
+ :colors( map { [ 0 xx $size ] }, ^$size),
+ :player-to-move(1) );
+}
=begin METHOD
Reports C<False> if the move is permissible in the given state of the game,
or a C<Str> explaining why if it isn't. (Thus 'bad' here means
'impermissible', but 'bad' is less to write.)
=end METHOD
- method is-move-bad(Str $move) {
- my $color = $!player-to-move;
+method is-move-bad(Str $move) {
+ my $color = $!player-to-move;
- given $move {
- when $.sarsen-move {
- my Int ($row, $column) = self.extract-coords($<coords>);
+ given $move {
+ when $.sarsen-move {
+ my Int ($row, $column) = self.extract-coords($<coords>);
- return $reason if my $reason
- = self.is-sarsen-move-bad($row, $column, $color);
- }
+ return $reason if my $reason
+ = self.is-sarsen-move-bad($row, $column, $color);
+ }
- when $.lintel-move {
- my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
- my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
+ when $.lintel-move {
+ my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
+ my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
- return $reason if my $reason
- = self.is-lintel-move-bad($row_1, $row_2,
- $column_1, $column_2,
- $color);
- }
+ return $reason if my $reason
+ = self.is-lintel-move-bad($row_1, $row_2,
+ $column_1, $column_2,
+ $color);
+ }
- when $.swap {
- return 'Swap is only allowed on second move'
- if $!moves-so-far != 1;
- }
+ when $.swap {
+ return 'Swap is only allowed on second move'
+ if $!moves-so-far != 1;
+ }
- when $.pass | $.resign {
- # those are always OK
- }
+ when $.pass | $.resign {
+ # those are always OK
+ }
- default {
- return '
+ default {
+ return '
The move does not conform to the accepted move syntax, which is either
something like "b2" or something like "c1-c3" You can also "pass" or
"resign" on any move, and "swap" on the second move of the game.'.substr(1);
- }
}
-
- return False; # move is OK
}
+ return False; # move is OK
+}
+
=begin METHOD
Returns, for given C<$row>, C<$column>, and C<$color>, the reason why
a sarsen (a one-block piece) of that color cannot be placed on that location,
or C<False> if the placing of the sarsen is permissible.
=end METHOD
- method is-sarsen-move-bad(Int $row, Int $column, Int $color) {
- return "The rightmost column is '{chr(ord('A')+$.size-1)}'"
- if $column >= $.size;
- return 'There is no row 0'
- if $row == -1;
- return "There are only {$.size} rows"
- if $row >= $.size;
-
- return sprintf q[Not %s's spot], <. vertical horizontal>[$color]
- unless $.colors[$row][$column] == 0|$color;
-
- return False; # The move is fine.
- }
+method is-sarsen-move-bad(Int $row, Int $column, Int $color) {
+ return "The rightmost column is '{chr(ord('A')+$.size-1)}'"
+ if $column >= $.size;
+ return 'There is no row 0'
+ if $row == -1;
+ return "There are only {$.size} rows"
+ if $row >= $.size;
+
+ return sprintf q[Not %s's spot], <. vertical horizontal>[$color]
+ unless $.colors[$row][$column] == 0|$color;
+
+ return False; # The move is fine.
+}
=begin METHOD
Returns, for a given C<$row_1>, C<$row_2>, C<$column_1>, C<$column_2>, and
@@ -123,206 +123,205 @@ There are no preconditions on the coordinate parameters to be exactly two
rows or two columns apart; instead, these conditions are also tested in this
method.
=end METHOD
- method is-lintel-move-bad(Int $row_1, Int $row_2,
- Int $column_1, Int $column_2,
- Int $color) {
-
- return "The rightmost column is '{chr(ord('A')+{$.size}-1)}'"
- if $column_1|$column_2 >= $.size;
- return 'There is no row 0'
- if $row_1|$row_2 == -1;
- return "There are only {$.size} rows"
- if $row_1|$row_2 >= $.size;
-
- my $row-diff = abs($row_1 - $row_2);
- my $column-diff = abs($column_1 - $column_2);
-
- return 'A lintel must be three units long'
- unless $row-diff == 2 && $column-diff == 0
- || $row-diff == 0 && $column-diff == 2;
-
- return 'A lintel must be supported at both ends'
- unless $.heights[$row_1][$column_1]
- == $.heights[$row_2][$column_2];
-
- my $row_m = ($row_1 + $row_2 ) / 2;
- my $column_m = ($column_1 + $column_2) / 2;
-
- return 'A lintel must lie flat'
- unless $.heights[$row_m][$column_m]
- <= $.heights[$row_1][$column_1];
-
- return 'A lintel cannot lie directly on the ground'
- unless $.heights[$row_1][$column_1];
-
- return 'A lintel must rest on exactly two pieces of its own color'
- unless 2 == elems grep { $_ == $color },
- $.colors[$row_1][$column_1], # one end...
- $.colors[$row_2][$column_2], # ...other end...
- $.heights[$row_m][$column_m] == $.heights[$row_1][$column_1]
- ?? $.colors[$row_m][$column_m] # ...middle piece only if
- !! (); # it's level with both ends
-
- return False; # The move is fine.
- }
+method is-lintel-move-bad(Int $row_1, Int $row_2,
+ Int $column_1, Int $column_2,
+ Int $color) {
+
+ return "The rightmost column is '{chr(ord('A')+{$.size}-1)}'"
+ if $column_1|$column_2 >= $.size;
+ return 'There is no row 0'
+ if $row_1|$row_2 == -1;
+ return "There are only {$.size} rows"
+ if $row_1|$row_2 >= $.size;
+
+ my $row-diff = abs($row_1 - $row_2);
+ my $column-diff = abs($column_1 - $column_2);
+
+ return 'A lintel must be three units long'
+ unless $row-diff == 2 && $column-diff == 0
+ || $row-diff == 0 && $column-diff == 2;
+
+ return 'A lintel must be supported at both ends'
+ unless $.heights[$row_1][$column_1]
+ == $.heights[$row_2][$column_2];
+
+ my $row_m = ($row_1 + $row_2 ) / 2;
+ my $column_m = ($column_1 + $column_2) / 2;
+
+ return 'A lintel must lie flat'
+ unless $.heights[$row_m][$column_m]
+ <= $.heights[$row_1][$column_1];
+
+ return 'A lintel cannot lie directly on the ground'
+ unless $.heights[$row_1][$column_1];
+
+ return 'A lintel must rest on exactly two pieces of its own color'
+ unless 2 == elems grep { $_ == $color },
+ $.colors[$row_1][$column_1], # one end...
+ $.colors[$row_2][$column_2], # ...other end...
+ $.heights[$row_m][$column_m] == $.heights[$row_1][$column_1]
+ ?? $.colors[$row_m][$column_m] # ...middle piece only if
+ !! (); # it's level with both ends
+
+ return False; # The move is fine.
+}
=begin METHOD
Analyzes a given move, and makes the appropriate changes to the attributes
of this C<Druid::Game>. C<fail>s if the move isn't valid.
=end METHOD
- method make-move(Str $move) {
-
- fail $reason
- if my $reason = self.is-move-bad($move);
+method make-move(Str $move) {
- my @pieces-to-put;
- my $color = $!player-to-move;
+ fail $reason
+ if my $reason = self.is-move-bad($move);
- given $move {
- when $.sarsen-move {
- my Int ($row, $column) = self.extract-coords($<coords>);
+ my @pieces-to-put;
+ my $color = $!player-to-move;
- my $height = @!heights[$row][$column];
- @pieces-to-put = $height, $row, $column;
- }
+ given $move {
+ when $.sarsen-move {
+ my Int ($row, $column) = self.extract-coords($<coords>);
- when $.lintel-move {
- my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
- my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
+ my $height = @!heights[$row][$column];
+ @pieces-to-put = $height, $row, $column;
+ }
- my $height = @!heights[$row_1][$column_1];
- my $row_m = ($row_1 + $row_2 ) / 2;
- my $column_m = ($column_1 + $column_2) / 2;
+ when $.lintel-move {
+ my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
+ my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
- @pieces-to-put = $height, $row_1, $column_1,
- $height, $row_m, $column_m,
- $height, $row_2, $column_2;
- }
+ my $height = @!heights[$row_1][$column_1];
+ my $row_m = ($row_1 + $row_2 ) / 2;
+ my $column_m = ($column_1 + $column_2) / 2;
- when $.pass {
- if $!latest-move ~~ $.pass {
- $!finished = True;
- }
- }
-
- when $.swap {
- .swap() for @!observers;
- }
+ @pieces-to-put = $height, $row_1, $column_1,
+ $height, $row_m, $column_m,
+ $height, $row_2, $column_2;
+ }
- when $.resign {
+ when $.pass {
+ if $!latest-move ~~ $.pass {
$!finished = True;
}
}
- for @pieces-to-put -> $height, $row, $column {
-
- if $height >= @!layers {
- push @!layers, [map { [0 xx $!size] }, ^$!size];
- }
- @!layers[$height][$row][$column]
- = @!colors[$row][$column]
- = $color;
- @!heights[$row][$column] = $height + 1;
+ when $.swap {
+ .swap() for @!observers;
+ }
- .add-piece($height, $row, $column, $color) for @!observers;
+ when $.resign {
+ $!finished = True;
}
+ }
- $!latest-move = $move;
- $!player-to-move = $color == 1 ?? 2 !! 1
- unless $move ~~ $.swap;
- $!moves-so-far++;
+ for @pieces-to-put -> $height, $row, $column {
- if self.move-was-winning() {
- $!finished = True;
+ if $height >= @!layers {
+ push @!layers, [map { [0 xx $!size] }, ^$!size];
}
+ @!layers[$height][$row][$column]
+ = @!colors[$row][$column]
+ = $color;
+ @!heights[$row][$column] = $height + 1;
- return $move;
+ .add-piece($height, $row, $column, $color) for @!observers;
}
+ $!latest-move = $move;
+ $!player-to-move = $color == 1 ?? 2 !! 1
+ unless $move ~~ $.swap;
+ $!moves-so-far++;
+
+ if self.move-was-winning() {
+ $!finished = True;
+ }
+
+ return $move;
+}
+
=begin METHOD
Returns a C<Bool> indicating whether the latest move created a winning chain
across the board.
=end METHOD
- submethod move-was-winning() {
-
- my ($row, $col) = self.extract-coords(
- $!latest-move ~~ $.sarsen-move ?? $<coords> !!
- $!latest-move ~~ $.lintel-move ?? $<coords>[0] !!
- return False # swap or pass or other kind of move
- );
-
- # Starting from the latest move made, traces the chains to determine
- # whether the two sides have been connected. Since the winning chain
- # must by necessity contain the last move, this is equivalent to
- # asking 'was the last move winning?'.
-
- my @pos-queue = { :$row, :$col };
-
- my $latest-color = @!colors[$row][$col];
-
- # The following four code variables take a step in either of the
- # four compass directions. Given a position as a two-entry hash
- # (:row, :col), it returns a neighboring position as a new such
- # hash or C<Bool::False> if the position would be outside of
- # the board.
- my &above
- = { .<row> < $!size - 1 && { :row(.<row> + 1), :col(.<col>) } };
- my &below
- = { .<row> > 0 && { :row(.<row> - 1), :col(.<col>) } };
- my &right
- = { .<col> < $!size - 1 && { :row(.<row>), :col(.<col> + 1) } };
- my &left
- = { .<col> > 0 && { :row(.<row>), :col(.<col> - 1) } };
-
- my %visited;
- my $reached-one-end = False;
- my $reached-other-end = False;
-
- while shift @pos-queue -> $pos {
- ++%visited{~$pos};
-
- for &above, &below, &right, &left -> &direction {
- my ($r, $c) = .<row>, .<col> given $pos;
- if direction($pos) -> $neighbor {
-
- if !%visited.exists(~$neighbor)
- && @!colors[$neighbor<row>][$neighbor<col>]
- == $latest-color {
-
- push @pos-queue, $neighbor;
- }
+submethod move-was-winning() {
+
+ my ($row, $col) = self.extract-coords(
+ $!latest-move ~~ $.sarsen-move ?? $<coords> !!
+ $!latest-move ~~ $.lintel-move ?? $<coords>[0] !!
+ return False # swap or pass or other kind of move
+ );
+
+ # Starting from the latest move made, traces the chains to determine
+ # whether the two sides have been connected. Since the winning chain
+ # must by necessity contain the last move, this is equivalent to
+ # asking 'was the last move winning?'.
+
+ my @pos-queue = { :$row, :$col };
+
+ my $latest-color = @!colors[$row][$col];
+
+ # The following four code variables take a step in either of the
+ # four compass directions. Given a position as a two-entry hash
+ # (:row, :col), it returns a neighboring position as a new such
+ # hash or C<Bool::False> if the position would be outside of
+ # the board.
+ my &above
+ = { .<row> < $!size - 1 && { :row(.<row> + 1), :col(.<col>) } };
+ my &below
+ = { .<row> > 0 && { :row(.<row> - 1), :col(.<col>) } };
+ my &right
+ = { .<col> < $!size - 1 && { :row(.<row>), :col(.<col> + 1) } };
+ my &left
+ = { .<col> > 0 && { :row(.<row>), :col(.<col> - 1) } };
+
+ my %visited;
+ my $reached-one-end = False;
+ my $reached-other-end = False;
+
+ while shift @pos-queue -> $pos {
+ ++%visited{~$pos};
+
+ for &above, &below, &right, &left -> &direction {
+ my ($r, $c) = .<row>, .<col> given $pos;
+ if direction($pos) -> $neighbor {
+
+ if !%visited.exists(~$neighbor)
+ && @!colors[$neighbor<row>][$neighbor<col>]
+ == $latest-color {
+
+ push @pos-queue, $neighbor;
}
}
+ }
- if $latest-color == 1 && !above($pos)
- || $latest-color == 2 && !right($pos) {
+ if $latest-color == 1 && !above($pos)
+ || $latest-color == 2 && !right($pos) {
- $reached-one-end = True;
- }
- elsif $latest-color == 1 && !below($pos)
- || $latest-color == 2 && !left($pos) {
-
- $reached-other-end = True;
- }
+ $reached-one-end = True;
+ }
+ elsif $latest-color == 1 && !below($pos)
+ || $latest-color == 2 && !left($pos) {
- return True if $reached-one-end && $reached-other-end;
+ $reached-other-end = True;
}
- return False;
+ return True if $reached-one-end && $reached-other-end;
}
+ return False;
+}
+
=begin METHOD
Returns a C<List> of the possible moves in this C<Druid::Game>, represented as
C<Str>s.
=end METHOD
- method possible-moves() {
- # We don't handle lintel moves yet. :( I have a nice O(1) algorithm,
- # but very little time.
- return gather for ^$!size -> $row {
- for ^$!size -> $column {
- if @!colors[$row][$column] == 0|$!player-to-move {
- take chr($column + ord("a")) ~ ($row+1);
- }
+method possible-moves() {
+ # We don't handle lintel moves yet. :( I have a nice O(1) algorithm,
+ # but very little time.
+ return gather for ^$!size -> $row {
+ for ^$!size -> $column {
+ if @!colors[$row][$column] == 0|$!player-to-move {
+ take chr($column + ord("a")) ~ ($row+1);
}
}
}
View
8 lib/Druid/Game/Observer.pm
@@ -1,4 +1,4 @@
-use v6;
+role Druid::Game::Observer;
=begin SUMMARY
This role enables objects to I<observe> a C<Druid::Game::Subject>, i.e.
@@ -12,19 +12,17 @@ Examples of classes which might want to observe a C<Druid::Game::Subject>
are classes derived from C<Druid::View> or C<Druid::Player>.
=end SUMMARY
-role Druid::Game::Observer {
=begin METHOD
Gets called any time the C<Druid::Game::Subject> adds a piece to its game
board. Note that, for the purposes of this method, lintels are considered
to be three adjacent (but separate) pieces.
=end METHOD
- method add-piece($height, $row, $column, $color) { ... };
+method add-piece($height, $row, $column, $color) { ... };
=begin METHOD
Gets called when the C<Druid::Game::Subject> swaps positions between the
two players.
=end METHOD
- method swap() { ... }
-}
+method swap() { ... }
# vim: filetype=perl6
View
17 lib/Druid/Game/Subject.pm
@@ -1,7 +1,8 @@
use v6;
-
use Druid::Game::Observer;
+role Druid::Game::Subject;
+
=begin SUMMARY
This role enables objects to be I<observed> by one or more
C<Druid::Game::Observer>s, i.e. to be notify these when the object changes
@@ -12,15 +13,13 @@ Examples of classes which might want to observe a C<Druid::Game::Subject>
are classes derived from C<Druid::View> or C<Druid::Player>.
=end SUMMARY
-role Druid::Game::Subject {
- # RAKUDO: Typed arrays don't really work yet
-# has Druid::Game::Observer @!observers;
- has @!observers;
+# RAKUDO: Typed arrays don't really work yet
+#has Druid::Game::Observer @!observers;
+has @!observers;
- method attach(Druid::Game::Observer $observer) {
- unless @!observers ~~ (*, $observer, *) {
- @!observers.push($observer);
- }
+method attach(Druid::Game::Observer $observer) {
+ unless @!observers ~~ (*, $observer, *) {
+ @!observers.push($observer);
}
}
View
34 lib/Druid/Player.pm
@@ -3,33 +3,33 @@ use v6;
use Druid::Game;
use Druid::Game::Observer;
+class Druid::Player is Druid::Base does Druid::Game::Observer;
+
=begin SUMMARY
Represents a generic Druid player. A player belongs to a certain game, has
a piece color in that game, and is responsible for choosing legal moves
and making them.
=end SUMMARY
-class Druid::Player is Druid::Base does Druid::Game::Observer {
=attr The game this C<Druid::Player> is playing.
- has Druid::Game $!game handles <size layers colors heights make-move>;
+has Druid::Game $!game handles <size layers colors heights make-move>;
=attr The color of this C<Druid::Player>'s pieces.
- has Int $.color where { $_ == 1|2 };
-
- # RAKUDO: This could be done with BUILD instead, as soon as BUILD can
- # access private attributes. [perl #64388]
- method new(Druid::Game :$game!, Int :$color! where { $_ == 1|2 }) {
- my $player = self.bless( self.CREATE(), :game($game), :color($color) );
- $game.attach($player);
- return $player;
- }
-
- method choose-move() { ... }
+has Int $.color where { $_ == 1|2 };
+
+# RAKUDO: This could be done with BUILD instead, as soon as BUILD can
+# access private attributes. [perl #64388]
+method new(Druid::Game :$game!, Int :$color! where { $_ == 1|2 }) {
+ my $player = self.bless( self.CREATE(), :game($game), :color($color) );
+ $game.attach($player);
+ return $player;
+}
- method swap() {
- $!color = $!color == 1 ?? 2 !! 1;
- }
+method choose-move() { ... }
- method Str() { return <Vertical Horizontal>[$!color-1] }
+method swap() {
+ $!color = $!color == 1 ?? 2 !! 1;
}
+method Str() { return <Vertical Horizontal>[$!color-1] }
+
# vim: filetype=perl6
View
24 lib/Druid/Player/Computer.pm
@@ -2,25 +2,25 @@ use v6;
use Druid::Player;
+class Druid::Player::Computer is Druid::Player;
+
=begin SUMMARY
A computer player. It currently only makes random sarsen moves, and is thus
ridiculously easily defeatable.
=end SUMMARY
-class Druid::Player::Computer is Druid::Player {
- method choose-move() {
- my ($row, $column);
- repeat {
- $row = (^$.size).pick[0];
- $column = (^$.size).pick[0];
- } until $.colors[$row][$column] == 0 | $!color;
+method choose-move() {
+ my ($row, $column);
+ repeat {
+ $row = (^$.size).pick[0];
+ $column = (^$.size).pick[0];
+ } until $.colors[$row][$column] == 0 | $!color;
- my $move = chr(ord('a')+$column) ~ ($row+1);
+ my $move = chr(ord('a')+$column) ~ ($row+1);
- say '';
- say "The computer moves $move";
- return $move;
- }
+ say '';
+ say "The computer moves $move";
+ return $move;
}
# vim: filetype=perl6
View
29 lib/Druid/Player/Human.pm
@@ -1,29 +1,28 @@
use v6;
use Druid::Player;
+class Druid::Player::Human is Druid::Player;
+
=begin SUMMARY
A human player, i.e. a C<Druid::Player> whose moves are typed in on C<$*IN>
by a human.
=end SUMMARY
-class Druid::Player::Human is Druid::Player {
- method choose-move() {
- do Whatever until my $move = self.input-valid-move();
- return $move;
- }
-
- submethod input-valid-move() {
-
- my $move = prompt("\n{self}: ");
- say '' and exit(1) if $*IN.eof;
+method choose-move() {
+ do Whatever until my $move = self.input-valid-move();
+ return $move;
+}
- if $!game.is-move-bad($move) -> $reason {
- say $reason;
- return;
- }
+submethod input-valid-move() {
+ my $move = prompt("\n{self}: ");
+ say '' and exit(1) if $*IN.eof;
- return $move;
+ if $!game.is-move-bad($move) -> $reason {
+ say $reason;
+ return;
}
+
+ return $move;
}
# vim: filetype=perl6
View
6 lib/Druid/View.pm
@@ -3,12 +3,12 @@ use v6;
use Druid::Game;
use Druid::Game::Observer;
+class Druid::View is Druid::Base does Druid::Game::Observer;
+
=begin SUMMARY
Base class for classes that represent a C<Druid::Game> visually.
=end SUMMARY
-class Druid::View is Druid::Base does Druid::Game::Observer {
- has Druid::Game $!game handles <size layers colors heights>;
-}
+has Druid::Game $!game handles <size layers colors heights>;
# vim: filetype=perl6
View
283 lib/Druid/View/Text.pm
@@ -3,17 +3,17 @@ use v6;
use Druid::Game;
use Druid::View;
+class Druid::View::Text is Druid::View;
+
=begin SUMMARY
A textual view of a C<Druid::Game>. Draws a large isometric 3D view, with
the pieces rendered as ASCII blocks, and two smaller 2D views giving
information about the colors and heights of the pieces on the board.
=end SUMMARY
-class Druid::View::Text is Druid::View {
-
- has $!cached-board;
+has $!cached-board;
- my $v-piece = '
+my $v-piece = '
+-----+
/|#v#v#|
||#v#v#|
@@ -21,7 +21,7 @@ class Druid::View::Text is Druid::View {
/-----/
';
- my $h-piece = '
+my $h-piece = '
+-----+
/|#h#h#|
||#h#h#|
@@ -29,17 +29,17 @@ class Druid::View::Text is Druid::View {
/-----/
';
- my $cover-right = '
+my $cover-right = '
#
#
';
- my $cover-top = '
+my $cover-top = '
#####
';
- my $cover-top-right = '
+my $cover-top-right = '
#
';
@@ -47,123 +47,123 @@ class Druid::View::Text is Druid::View {
Returns a string containing an ASCII picture of an empty Druid board of
the given size.
=end METHOD
- sub make-empty-board($size) {
- # The 'join $sep, gather { ... }' pattern allows us to put a long
- # string together, without having to refer to the same variable over
- # and over.
- return join "\n", gather {
- take '';
- take my $heading
- = [~] ' ', map {" $_ "}, map {chr($_+ord('A'))}, ^$size;
- take my $line = [~] ' ', '+-----' x $size, '+';
- for (1..$size).reverse -> $r {
- take [~] (sprintf '%2d |', $r),
- ' ' x ($size) - 1,
- " | $r";
- take [~] ' |', ' ' x ($size) - 1, ' |';
- if $r > 1 {
- take [~] ' +', ' +' x $size;
- }
+sub make-empty-board($size) {
+ # The 'join $sep, gather { ... }' pattern allows us to put a long
+ # string together, without having to refer to the same variable over
+ # and over.
+ return join "\n", gather {
+ take '';
+ take my $heading
+ = [~] ' ', map {" $_ "}, map {chr($_+ord('A'))}, ^$size;
+ take my $line = [~] ' ', '+-----' x $size, '+';
+ for (1..$size).reverse -> $r {
+ take [~] (sprintf '%2d |', $r),
+ ' ' x ($size) - 1,
+ " | $r";
+ take [~] ' |', ' ' x ($size) - 1, ' |';
+ if $r > 1 {
+ take [~] ' +', ' +' x $size;
}
- take $line;
- take $heading;
- take '';
- };
- }
-
- # RAKUDO: This could be done with BUILD instead, as soon as BUILD can
- # access private attributes. [perl #64388]
- method new(Druid::Game :$game!) {
- my $view = self.bless( self.CREATE(),
- :$game,
- :cached-board(make-empty-board($game.size)) );
- $game.attach($view);
- return $view;
- }
+ }
+ take $line;
+ take $heading;
+ take '';
+ };
+}
+
+# RAKUDO: This could be done with BUILD instead, as soon as BUILD can
+# access private attributes. [perl #64388]
+method new(Druid::Game :$game!) {
+ my $view = self.bless( self.CREATE(),
+ :$game,
+ :cached-board(make-empty-board($game.size)) );
+ $game.attach($view);
+ return $view;
+}
=begin METHOD
Prints the 3D game board and the two smaller sub-boards, reflecting the
current state of the game.
=end METHOD
- method show() {
- .print for $!cached-board, self.colors-and-heights();
- }
+method show() {
+ .print for $!cached-board, self.colors-and-heights();
+}
=begin METHOD
Returns the 3D game board and the two smaller sub-boards, reflecting the
current state of the game.
=end METHOD
- method Str() {
- return [~] $!cached-board, self.colors-and-heights();
- }
+method Str() {
+ return [~] $!cached-board, self.colors-and-heights();
+}
- method build-layers($board is copy, $from) {
- # RAKUDO: Something strange happens when passing Ints as parameters
- my $from-copy = +$from;
- # RAKUDO: Something about array indices and list context
- my @layers = $from-copy == @.layers.end
- ?? @.layers[$from-copy]
- !! @.layers[$from-copy .. @.layers.end];
- for @layers.kv -> $relheight, $layer {
- my $height = $relheight + $from-copy;
- for $layer.kv.reverse -> $line, $row {
- for $line.kv.reverse -> $cell, $column {
-
- next if $cell == 0;
-
- given ($v-piece, $h-piece)[$cell-1] -> $piece {
- $board = put( $piece, $board, $height, $row, $column );
- if $column < $.size - 1
- && $layer[$row][$column] == $layer[$row][$column+1] {
- $board = put( $cover-right, $board,
- $height, $row, $column );
- }
- if $row < $.size - 1
- && $layer[$row][$column] == $layer[$row+1][$column] {
- $board = put( $cover-top, $board,
- $height, $row, $column );
- }
- if $row & $column < $.size - 1
- && $layer[$row][$column]
- == $layer[$row+1][$column]
- == $layer[$row][$column+1]
- == $layer[$row+1][$column+1] {
- $board = put( $cover-top-right, $board,
- $height, $row, $column );
- }
+method build-layers($board is copy, $from) {
+ # RAKUDO: Something strange happens when passing Ints as parameters
+ my $from-copy = +$from;
+ # RAKUDO: Something about array indices and list context
+ my @layers = $from-copy == @.layers.end
+ ?? @.layers[$from-copy]
+ !! @.layers[$from-copy .. @.layers.end];
+ for @layers.kv -> $relheight, $layer {
+ my $height = $relheight + $from-copy;
+ for $layer.kv.reverse -> $line, $row {
+ for $line.kv.reverse -> $cell, $column {
+
+ next if $cell == 0;
+
+ given ($v-piece, $h-piece)[$cell-1] -> $piece {
+ $board = put( $piece, $board, $height, $row, $column );
+ if $column < $.size - 1
+ && $layer[$row][$column] == $layer[$row][$column+1] {
+ $board = put( $cover-right, $board,
+ $height, $row, $column );
+ }
+ if $row < $.size - 1
+ && $layer[$row][$column] == $layer[$row+1][$column] {
+ $board = put( $cover-top, $board,
+ $height, $row, $column );
+ }
+ if $row & $column < $.size - 1
+ && $layer[$row][$column]
+ == $layer[$row+1][$column]
+ == $layer[$row][$column+1]
+ == $layer[$row+1][$column+1] {
+ $board = put( $cover-top-right, $board,
+ $height, $row, $column );
}
}
}
}
-
- return $board;
}
+ return $board;
+}
+
=begin SUBROUTINE
Given a string representing a piece and one representing the board,
returns a new board with the piece inserted into some coordinates. This
sub assumes that pieces are drawn in an order that makes sense, so that
pieces in front cover those behind.
=end SUBROUTINE
- sub put($piece, $board, $height, $row, $column) {
- my @lines = $board.split("\n");
+sub put($piece, $board, $height, $row, $column) {
+ my @lines = $board.split("\n");
- my $coord-line = +@lines - 8 - 3 * $row - $height;
+ my $coord-line = +@lines - 8 - 3 * $row - $height;
- return put($piece, "\n" ~ $board, $height, $row, $column)
- if $coord-line < 0;
+ return put($piece, "\n" ~ $board, $height, $row, $column)
+ if $coord-line < 0;
- my $coord-column = 3 + 6 * $column + $height;
+ my $coord-column = 3 + 6 * $column + $height;
- for $piece.split("\n").kv -> $line-no, $piece-line {
- my $board-line = @lines[$coord-line + $line-no];
- @lines[ $coord-line + $line-no ]
- = merge($board-line, $piece-line, $coord-column);
- }
-
- return @lines.join("\n");
+ for $piece.split("\n").kv -> $line-no, $piece-line {
+ my $board-line = @lines[$coord-line + $line-no];
+ @lines[ $coord-line + $line-no ]
+ = merge($board-line, $piece-line, $coord-column);
}
+ return @lines.join("\n");
+}
+
=begin SUBROUTINE
Given a string (assumed to contain no newlines), replaces a section of
that string, starting from $column, with the contents of $new.
@@ -175,63 +175,62 @@ When replacing characters, two excpetions are made:
octothorpes '#' insert actual spaces, i.e. act as a sort of
escape character for spaces.
=end SUBROUTINE
- sub merge($old, $new, $start) {
- my @old = $old.split('');
- my @new = $new.split('');
+sub merge($old, $new, $start) {
+ my @old = $old.split('');
+ my @new = $new.split('');
- # RAKUDO: xx and push don't seem to work as advertised.
- push @old, ' ' for ^($start + $new.chars - $old.chars);
+ # RAKUDO: xx and push don't seem to work as advertised.
+ push @old, ' ' for ^($start + $new.chars - $old.chars);
- for @new.kv -> $i, $char {
- @old[$start + $i] = $char unless $char eq ' ';
- @old[$start + $i] = ' ' if $char eq '#'
- }
-
- return @old.join('');
+ for @new.kv -> $i, $char {
+ @old[$start + $i] = $char unless $char eq ' ';
+ @old[$start + $i] = ' ' if $char eq '#'
}
+ return @old.join('');
+}
+
=begin METHOD
Prints two smaller boards representing
=item who owns each location, and
=item how many stones have been piled on each location.
=end METHOD
- method colors-and-heights() {
-
- my &from-pretty = { $^pretty.trans( ['>>', '<<', '.']
- => ['%2d','%-2d','%s'] ) };
-
- my &format-colors = { <. v h>[$^color] };
- my &format-heights = { $^height || '.' };
-
- my $letters = 'A'..chr(ord('A') + $.size - 1);
-
- my $inter-board-space
- = ' ' x (1 + 6*$.size - 2*$.size - 2*($.size-1) - 14);
- my $board-line = [~] '>> ', ('.' xx $.size).join(' '), ' <<';
-
- my $footer = [~] "\n ", $letters.join(' '),
- ' ' x 8, $inter-board-space,
- $letters.join(' '), "\n";
- my $header = "$footer\n";
-
- return gather {
- take $header;
- # RAKUDO: .reverse on Ranges out of order. [perl #64458]
- for (1..$.size).list.reverse -> $row {
- take sprintf from-pretty(
- [~] ' ', $board-line, $inter-board-space, $board-line
- ),
- $row, (map &format-colors, @.colors[$row-1].values), $row,
- $row, (map &format-heights, @.heights[$row-1].values), $row;
- take "\n";
- }
- take $footer;
- };
- }
+method colors-and-heights() {
+
+ my &from-pretty = { $^pretty.trans( ['>>', '<<', '.']
+ => ['%2d','%-2d','%s'] ) };
+
+ my &format-colors = { <. v h>[$^color] };
+ my &format-heights = { $^height || '.' };
+
+ my $letters = 'A'..chr(ord('A') + $.size - 1);
+
+ my $inter-board-space
+ = ' ' x (1 + 6*$.size - 2*$.size - 2*($.size-1) - 14);
+ my $board-line = [~] '>> ', ('.' xx $.size).join(' '), ' <<';
+
+ my $footer = [~] "\n ", $letters.join(' '),
+ ' ' x 8, $inter-board-space,
+ $letters.join(' '), "\n";
+ my $header = "$footer\n";
+
+ return gather {
+ take $header;
+ # RAKUDO: .reverse on Ranges out of order. [perl #64458]
+ for (1..$.size).list.reverse -> $row {
+ take sprintf from-pretty(
+ [~] ' ', $board-line, $inter-board-space, $board-line
+ ),
+ $row, (map &format-colors, @.colors[$row-1].values), $row,
+ $row, (map &format-heights, @.heights[$row-1].values), $row;
+ take "\n";
+ }
+ take $footer;
+ };
+}
- method add-piece($height, $row, $column, $color) {
- $!cached-board = self.build-layers($!cached-board, $height);
- }
+method add-piece($height, $row, $column, $color) {
+ $!cached-board = self.build-layers($!cached-board, $height);
}
# vim: filetype=perl6
Please sign in to comment.
Something went wrong with that request. Please try again.