Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[Druid] put rules in a grammar so that they work

  • Loading branch information...
commit 383fc260b063743022895d5595ed8afdad6c3eba 1 parent 86de6df
Carl Mäsak authored November 08, 2010
38  lib/Druid/Base.pm
... ...
@@ -1,25 +1,27 @@
1 1
 # = Base class collecting ambient regexes, attributes and methods.
2  
-class Druid::Base;
  2
+grammar Druid::Move {
  3
+    # RAKUDO: Cannot use dashes here. [perl #64464]
  4
+    regex col_letter { <[a..z]> }
  5
+    regex row_number { \d+ }
  6
+    regex coords { <col_letter><row_number> }
3 7
 
4  
-# RAKUDO: Cannot use dashes here. [perl #64464]
5  
-regex col_letter { <[a..z]> }
6  
-regex row_number { \d+ }
7  
-regex coords { <col_letter><row_number> }
8  
-
9  
-our $.sarsen-move = /^ <coords> $/;              # = A sarsen (length 1) move
10  
-our $.lintel-move = /^ <coords> '-' <coords> $/; # = A lintel (length 3) move
11  
-our $.pass   = /^ ['pass'   | 'p'] $/;           # = A passing (no-op) move
12  
-our $.swap   = /^ ['swap'   | 's'] $/;           # = A swap move
13  
-our $.resign = /^ ['resign' | 'r'] $/;           # = A forfeit
  8
+    regex sarsen-move { ^ <coords> $ }              # = A sarsen (length 1) move
  9
+    regex lintel-move { ^ <coords> '-' <coords> $ } # = A lintel (length 3) move
  10
+    regex pass     { ['pass'   | 'p'] $ }           # = A passing (no-op) move
  11
+    regex swap     { ['swap'   | 's'] $ }           # = A swap move
  12
+    regex resign   { ['resign' | 'r'] $ }           # = A forfeit
  13
+}
14 14
 
15  
-# = Returns (zero-based) row and column, given a C<Match> object
16  
-method extract-coords(Match $m) {
17  
-    # RAKUDO: Hoping these explicit (...).Int conversions won't be
18  
-    #         necessary in the long run.
19  
-    my Int $row    = ($m<row_number> - 1).Int;
20  
-    my Int $column = (ord($m<col_letter>) - ord('a')).Int;
  15
+class Druid::Base {
  16
+    # = Returns (zero-based) row and column, given a C<Match> object
  17
+    method extract-coords(Match $m) {
  18
+        # RAKUDO: Hoping these explicit (...).Int conversions won't be
  19
+        #         necessary in the long run.
  20
+        my Int $row    = ($m<row_number> - 1).Int;
  21
+        my Int $column = (ord($m<col_letter>) - ord('a')).Int;
21 22
 
22  
-    return ($row, $column);
  23
+        return ($row, $column);
  24
+    }
23 25
 }
24 26
 
25 27
 # vim: filetype=perl6
33  lib/Druid/Game.pm
@@ -71,14 +71,14 @@ method is-move-bad(Str $move) {
71 71
     my $color = $!player-to-move;
72 72
 
73 73
     given $move {
74  
-        when $.sarsen-move {
  74
+        when Druid::Move.parse($_, :rule<sarsen-move>) {
75 75
             my Int ($row, $column) = self.extract-coords($<coords>);
76 76
 
77 77
             return $reason if my $reason
78 78
                 = self.is-sarsen-move-bad($row, $column, $color);
79 79
         }
80 80
 
81  
-        when $.lintel-move {
  81
+        when Druid::Move.parse($_, :rule<lintel-move>) {
82 82
             my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
83 83
             my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
84 84
 
@@ -88,12 +88,13 @@ method is-move-bad(Str $move) {
88 88
                                           $color);
89 89
         }
90 90
 
91  
-        when $.swap {
  91
+        when Druid::Move.parse($_, :rule<swap>) {
92 92
             return 'Swap is only allowed on second move'
93 93
                 if $!moves-so-far != 1;
94 94
         }
95 95
 
96  
-        when $.pass | $.resign {
  96
+        when Druid::Move.parse($_, :rule<pass>)
  97
+             || Druid::Move.parse($move, :rule<resign>) {
97 98
             # those are always OK
98 99
         }
99 100
 
@@ -101,7 +102,7 @@ method is-move-bad(Str $move) {
101 102
             return '
102 103
 The move does not conform to the accepted move syntax, which is either
103 104
 something like "b2" or something like "c1-c3" You can also "pass" or
104  
-"resign" on any move, and "swap" on the second move of the game.'.substr(1);
  105
+"resign" on any move, and "swap" on the second move of the game.'.trim-leading;
105 106
         }
106 107
     }
107 108
 
@@ -166,12 +167,12 @@ method is-lintel-move-bad(Int $row_1, Int $row_2,
166 167
         unless $.heights[$row_1][$column_1];
167 168
 
168 169
     return 'A lintel must rest on exactly two pieces of its own color'
169  
-        unless 2 == elems grep { $_ == $color },
  170
+        unless 2 == (grep { $_ == $color },
170 171
             $.colors[$row_1][$column_1],        # one end...
171 172
             $.colors[$row_2][$column_2],        # ...other end...
172 173
             $.heights[$row_m][$column_m] == $.heights[$row_1][$column_1]
173 174
                 ?? $.colors[$row_m][$column_m]  # ...middle piece only if
174  
-                !! ();                          # it's level with both ends
  175
+                !! ()).elems;                   # it's level with both ends
175 176
 
176 177
     return False; # The move is fine.
177 178
 }
@@ -187,14 +188,14 @@ method make-move(Str $move) {
187 188
     my $color = $!player-to-move;
188 189
 
189 190
     given $move {
190  
-        when $.sarsen-move {
  191
+        when Druid::Move.parse($_, :rule<sarsen-move>) {
191 192
             my Int ($row, $column) = self.extract-coords($<coords>);
192 193
 
193 194
             my $height     = @!heights[$row][$column];
194 195
             @pieces-to-put = $height, $row, $column;
195 196
         }
196 197
 
197  
-        when $.lintel-move {
  198
+        when Druid::Move.parse($_, :rule<lintel-move>) {
198 199
             my Int ($row_1, $column_1) = self.extract-coords($<coords>[0]);
199 200
             my Int ($row_2, $column_2) = self.extract-coords($<coords>[1]);
200 201
 
@@ -207,17 +208,17 @@ method make-move(Str $move) {
207 208
                              $height, $row_2, $column_2;
208 209
         }
209 210
 
210  
-        when $.pass {
211  
-            if $!latest-move ~~ $.pass {
  211
+        when Druid::Move.parse($_, :rule<pass>) {
  212
+            if Druid::Move.parse($!latest-move, :rule<pass>) {
212 213
                 $!finished = True;
213 214
             }
214 215
         }
215 216
 
216  
-        when $.swap {
  217
+        when Druid::Move.parse($_, :rule<swap>) {
217 218
             .swap() for @!observers;
218 219
         }
219 220
 
220  
-        when $.resign {
  221
+        when Druid::Move.parse($_, :rule<resign>) {
221 222
             $!finished = True;
222 223
         }
223 224
     }
@@ -237,7 +238,7 @@ method make-move(Str $move) {
237 238
 
238 239
     $!latest-move = $move;
239 240
     $!player-to-move = $color == 1 ?? 2 !! 1
240  
-        unless $move ~~ $.swap;
  241
+        unless Druid::Move.parse($move, :rule<swap>);
241 242
     $!moves-so-far++;
242 243
 
243 244
     if self.move-was-winning() {
@@ -252,8 +253,8 @@ method make-move(Str $move) {
252 253
 submethod move-was-winning() {
253 254
 
254 255
     my ($row, $col) = self.extract-coords(
255  
-        $!latest-move ~~ $.sarsen-move ?? $<coords>    !!
256  
-        $!latest-move ~~ $.lintel-move ?? $<coords>[0] !!
  256
+        Druid::Move.parse($!latest-move, :rule<sarsen-move>) ?? $<coords>    !!
  257
+        Druid::Move.parse($!latest-move, :rule<lintel-move>) ?? $<coords>[0] !!
257 258
         return False # swap or pass or other kind of move
258 259
     );
259 260
 

0 notes on commit 383fc26

Please sign in to comment.
Something went wrong with that request. Please try again.