Add a simple hangman game

Raku · Oct 30, 2009 · ae1080b · ae1080b
1 parent d7fbc55
commit ae1080b
Show file tree

Hide file tree

Showing 3 changed files with 7,434 additions and 0 deletions.
diff --git a/wip/README b/wip/README
@@ -0,0 +1,3 @@
+This directory is called wip for Work In Progress.
+
+It is a place for undeveloped ideas that might or might not be book-worthy
diff --git a/wip/hangman.p6 b/wip/hangman.p6
@@ -0,0 +1,80 @@
+#!/usr/bin/perl6
+
+# Simple hangman game to illustrate Perl 6.
+# Very procedural.  No OOP.  Uses scalars, arrays, and hashes
+
+# TODO: needs cleaning
+
+use v6;
+
+my $dictionary = shift(@*ARGS) // 'words';
+my @words = read-dictionary($dictionary);
+my $alphabet = "abcdefghijklmnopqrstuvwxyz";
+my @hangman = <head torso left_arm right_arm left_leg right_leg>;
+
+loop {
+    my $word = @words[rand * +@words];
+    my @blanks = "_" xx chars($word);
+
+    my (@hanging,%missed,%guessed); 
+    my $i = 0;
+    while @hanging != @hangman {
+        say "          Word: " ~ join(" ", @blanks);
+        say "Letters missed: " ~ join(" ", sort keys %missed);
+        say "       Hangman: " ~ join(" ", @hanging);
+        if join('',@blanks) eq $word { say "\t\tYou Win!"; last; }
+        say "Enter a letter ...";
+        my $guess = substr(lc(get($*IN)), 0, 1);        # only take first char
+        if not defined(index($alphabet,$guess)) { 
+            say "That's not a letter!"; 
+            next; 
+        }
+        if %guessed{$guess} { 
+            say "You already guessed that letter!"; 
+            next; 
+        }
+        %guessed{$guess}++;
+        if defined(index($word,$guess)) { 
+            say "yes"; 
+            @blanks = fill-blanks(@blanks,$word,$guess); 
+        }
+        else { 
+            say "no";
+            push(@hanging, @hangman[$i++]); 
+            %missed{$guess}++; 
+        }
+    }
+    say "\t\tYou lose!\nThe word was ''$word''" if @hanging == @hangman;
+    say "Try again? (Y/n)";
+    my $answer = get($*IN);
+    last if lc(substr($answer,0,1)) eq 'n';
+}
+say "Thanks for playing!";
+exit;
+
+sub read-dictionary ($dictionary) {
+    say "Reading dictionary...";
+    my $fh = open $dictionary, :r or die;
+    my @words;
+    for lines($fh) <-> $line {
+        chomp($line);                       # remove newline
+        $line = lc($line);                  # make all words lower case
+        next unless chars($line) > 4;       # only take words with more than 4 characters
+        push(@words,$line);
+    }
+    say "Done.";
+    return @words;
+}
+
+sub fill-blanks(@blanks is copy,$word,$letter) {
+    return unless $letter;
+    @blanks = "_" xx chars($word) if !@blanks;
+    my $next_pos = 0;
+    loop { 
+        my $pos = index($word,$letter,$next_pos);
+        last unless defined $pos;
+        @blanks[$pos] = $letter;
+        $next_pos = $pos+1;
+    }
+    return @blanks;
+}