Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[bin/crypt] parse commands with a grammar

This will make lue++ happy. :)
  • Loading branch information...
commit 51cbe97931f4dd4a85f0846b7e1072dad043c39c 1 parent 4b750af
Carl Mäsak authored July 29, 2012

Showing 1 changed file with 61 additions and 17 deletions. Show diff stats Hide diff stats

  1. 78  bin/crypt
78  bin/crypt
@@ -1440,6 +1440,23 @@ multi MAIN() {
1440 1440
     }
1441 1441
     my %commands = map { $^m.name => params($m) }, $game.^methods;
1442 1442
 
  1443
+    my %verb_synonyms =
  1444
+        "go"        => "walk",
  1445
+        "l"         => "look",
  1446
+        "x"         => "examine",
  1447
+        "place"     => "put",
  1448
+        "put"       => "put",
  1449
+        "pick"      => "take",
  1450
+        "pick up"   => "take",
  1451
+        "get"       => "take",
  1452
+        "retrieve"  => "take",
  1453
+        "retreive"  => "take",  # might as well
  1454
+        "turn on"   => "use",
  1455
+        "switch on" => "use",
  1456
+        "i"         => "inventory",
  1457
+    ;
  1458
+    my @verbs = %commands.keys, %verb_synonyms.keys;
  1459
+
1443 1460
     my @possible_directions = <
1444 1461
         north south east west
1445 1462
         northeast northwest southeast southwest
@@ -1522,19 +1539,56 @@ inventory";
1522 1539
                 }
1523 1540
             }
1524 1541
 
1525  
-            when /^ [''|go \h+] (\w+)
1526  
-                    <?{ $0 eq any @possible_directions }> $/ {
1527  
-                $command = "walk $0";
  1542
+            when any @possible_directions {
  1543
+                $command = "walk $command";
1528 1544
                 proceed;
1529 1545
             }
1530 1546
 
  1547
+            my grammar Command {
  1548
+                regex TOP {
  1549
+                    ^
  1550
+                    [
  1551
+                    | $<verb>='move' \h+ $<arg1>=[\w+] \h+ $<arg2>=[\w+]
  1552
+                    | <verb>
  1553
+                      [
  1554
+                          \h+ ['the' \h+]? $<arg1>=<.noun>
  1555
+                          [
  1556
+                              \h+ <prep> \h+ ['the' \h+]? $<arg2>=<.noun>
  1557
+                          ]?
  1558
+                      ]?
  1559
+                    ]
  1560
+                    $
  1561
+                }
  1562
+                regex verb { \w+ [\h+ \w+]?? <?{ $/ eq any @verbs }> }
  1563
+                regex noun { \w+ [\h+ 'disk']? }
  1564
+                regex prep { 'in' | 'on' }
  1565
+            }
  1566
+
  1567
+            when !Command.parse($command) {
  1568
+                say "Sorry, I did not understand that.";
  1569
+            }
  1570
+
  1571
+            my $verb = %verb_synonyms{$<verb>} // ~$<verb>;
  1572
+            my @args;
  1573
+            if $<arg1> {
  1574
+                push @args, ~$<arg1>;
  1575
+                if $<arg2> {
  1576
+                    if $verb eq 'put' {
  1577
+                        $verb = "put_thing_$<prep>";
  1578
+                    }
  1579
+                    push @args, ~$<arg2>;
  1580
+                }
  1581
+            }
  1582
+
1531 1583
             when /^ :s [move|put] [the]?
1532 1584
                     $<disk>=[tiny||small||medium||large||huge]
1533 1585
                     disk [on|to] [the]?
1534 1586
                     $<target>=[left||middle||right]
1535 1587
                     rod $/ {
1536 1588
 
1537  
-                $command = "move $<disk> $<target>";
  1589
+                $verb = 'move';
  1590
+                @args = ~$<disk>, ~$<target>;
  1591
+                proceed;
1538 1592
             }
1539 1593
 
1540 1594
             when /^ :s [move|put] [the]?
@@ -1543,18 +1597,11 @@ inventory";
1543 1597
                     $<target>=[left||middle||right]
1544 1598
                     rod $/ {
1545 1599
 
1546  
-                $command = "move $<source> $<target>";
1547  
-            }
1548  
-
1549  
-            when /^ 'put' \h+ (\w+) \h+ ('in'|'on') \h+ (\w+) $/ {
1550  
-                $command = "put_thing_$1 $0 $2";
  1600
+                $verb = 'move';
  1601
+                @args = ~$<source>, ~$<target>;
1551 1602
                 proceed;
1552 1603
             }
1553 1604
 
1554  
-            sub munge   { $^s.subst(/' disk'»/, '_disk', :g) }
1555  
-            sub unmunge { $^s.subst(/'_disk'»/, ' disk', :g) }
1556  
-            my $verb = .&munge.words[0].&unmunge;
1557  
-            my @args = .&munge.words[1..*]».&unmunge;
1558 1605
             when %commands.exists($verb) {
1559 1606
                 my @req_args = %commands{$verb}.list;
1560 1607
                 when @args != @req_args {
@@ -1644,12 +1691,9 @@ inventory";
1644 1691
                 CATCH {
1645 1692
                     when X::Adventure { say .message, '.' }
1646 1693
                     when X::Hanoi { say .message, '.' }
  1694
+                    when X::Crypt { say .message, '.' }
1647 1695
                 }
1648 1696
             }
1649  
-
1650  
-            default {
1651  
-                say "Sorry, I did not understand that.";
1652  
-            }
1653 1697
         }
1654 1698
         say "";
1655 1699
     }

0 notes on commit 51cbe97

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