Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[bin/crypt] implement hanoi CLI client

  • Loading branch information...
commit 72ef665c3faec428968eaa7a4db66c43ea3f4802 1 parent bb828fb
Carl Mäsak authored July 02, 2012

Showing 1 changed file with 95 additions and 0 deletions. Show diff stats Hide diff stats

  1. 95  bin/crypt
95  bin/crypt
@@ -243,6 +243,101 @@ sub throws_exception(&code, $ex_type, $message, &followup?) {
243 243
     }
244 244
 }
245 245
 
  246
+multi MAIN('hanoi') {
  247
+    my Hanoi::Game $game .= new;
  248
+    my @disks = <tiny small medium large huge> X~ ' disk';
  249
+    my @rods = <left middle right>;
  250
+
  251
+    sub params($method) {
  252
+        $method.signature.params
  253
+            ==> grep { .positional && !.invocant }
  254
+            ==> map { .name.substr(1) }
  255
+    }
  256
+    my %commands = map { $^m.name => params($m) }, $game.^methods;
  257
+    my @all_events;
  258
+
  259
+    sub print_board() {
  260
+        my %s =
  261
+            left   => [reverse @disks],
  262
+            middle => [],
  263
+            right  => [],
  264
+        ;
  265
+        for @all_events {
  266
+            when Hanoi::DiskMoved   { %s{.target}.push: %s{.source}.pop }
  267
+            when Hanoi::DiskRemoved { %s{.source}.pop }
  268
+            when Hanoi::DiskAdded   { %s{.target}.push: .disk }
  269
+        }
  270
+
  271
+        say "";
  272
+        for reverse ^6 -> $line {
  273
+            my %disks =
  274
+                'none'        => '     |     ',
  275
+                'tiny disk'   => '     =     ',
  276
+                'small disk'  => '    ===    ',
  277
+                'medium disk' => '   =====   ',
  278
+                'large disk'  => '  =======  ',
  279
+                'huge disk'   => ' ========= ',
  280
+            ;
  281
+
  282
+            sub disk($rod) {
  283
+                my $disk = %s{$rod}[$line] // 'none';
  284
+                %disks{ $disk };
  285
+            }
  286
+
  287
+            say join '  ', map &disk, @rods;
  288
+        }
  289
+        say join '--', '-----------' xx @rods;
  290
+        say "";
  291
+    }
  292
+
  293
+    print_board();
  294
+    loop {
  295
+        my $command = prompt('> ');
  296
+        unless defined $command {
  297
+            say "";
  298
+            last;
  299
+        }
  300
+        given lc $command {
  301
+            when 'q' | 'quit' { last }
  302
+            when 'h' | 'help' {
  303
+                say "Available commands:";
  304
+                for %commands.sort {
  305
+                    say "  {.key} {map { "<$_>" }, .value.list}";
  306
+                }
  307
+                say "";
  308
+                say "Disks: ", join ', ', @disks;
  309
+                say "Rods: ", join ', ', @rods;
  310
+            }
  311
+
  312
+            sub munge   { $^s.subst(/' disk'»/, '_disk', :g) }
  313
+            sub unmunge { $^s.subst(/'_disk'»/, ' disk', :g) }
  314
+            $command .= &munge;
  315
+            my $verb = $command.words[0].&unmunge;
  316
+            my @args = $command.words[1..*]».&unmunge;
  317
+            when %commands.exists($verb) {
  318
+                my @req_args = %commands{$verb}.list;
  319
+                when @args != @req_args {
  320
+                    say "You passed in {+@args} arguments, but $verb requires {+@req_args}.";
  321
+                    say "The arguments are {map { "<$_>" }, @req_args}.";
  322
+                    say "'help' for more help.";
  323
+                }
  324
+                my @events = $game."$verb"(|@args);
  325
+                push @all_events, @events;
  326
+                print_board();
  327
+                CATCH {
  328
+                    when X::Hanoi { say .message }
  329
+                }
  330
+            }
  331
+
  332
+            default {
  333
+                say "Sorry, the game doesn't recognize that command. :/";
  334
+                say "'help' if you're confused as well.";
  335
+            }
  336
+        }
  337
+        say "";
  338
+    }
  339
+}
  340
+
246 341
 multi MAIN('test', 'hanoi') {
247 342
     {
248 343
         my $game = Hanoi::Game.new();

0 notes on commit 72ef665

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