Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

"Countdown" (golf)

by stuffy (Monk)
on Nov 30, 2001 at 11:27 UTC ( #128568=perlmeditation: print w/replies, xml ) Need Help??

Hello all,
I was recently in London, and while relaxing in the hotel room one day, I saw a cool game show called "Countdown." One part of the game requires contestants to find the longest word possible when given 9 letters. For example if the letters "d u n s c a e y t" came up, one possible answer with 6 letters would be "sunday" another would be "uneasy" Once all the letters are up, the contestants get 30 seconds to come up with an answer.
Well, I'm too lazy to think about such things when a computer can do it for me. Here's the challenge:
Write a program that will take the given letters and using the (english) spell check dictionary of your choice make and verify the validity of the longest word possible. There will always be 9 letters to start with. There may be multiple words with the same number of letters. The output should include all words with the highest number of letters.
If this gets a good response, I will post the numerical part of the game...so those of you that know the game, you have a head start.

update gbarr and dragonchild have so far come the closest to solving the problem. If you change the letters to "d u n s c a e y z" the highest number of letters returned is 6, and both of their solutions only print out "ascend" again, "uneasy" contains 6 letters as well and should also show up as well as "sunday" (if adjusted for case insensitiveness as I did in the test)

Stuffy
That's my story, and I'm sticking to it, unless I'm wrong in which case I will probably change it ;~)
may be reproduced under the SDL

Replies are listed 'Best First'.
Re: "Countdown" (golf)
by blakem (Monsignor) on Nov 30, 2001 at 12:59 UTC
    Here is my initial entry... I took a few liberties though:

    1. Opened a words file outside the subroutine
    2. Passed in letters as array not array ref or string (method wasn't specified above)
    3. Case sensitive... I don't match 'Sunday' because I wasn't passed a capital S.
    4. Returns a large set of matching words, w/o looking for the longest ones..... that wasn't the "interesting" part of the course for me, so I punted. ;-)

    So, here's my first second fourth attempt at 64 chars:

    my @letters = qw(d u n s c a e y t); open(D,"/usr/dict/words") or die $!; my @words = f(@letters); print "$_\n" for @words; sub f { # 1 2 3 4 5 6 #234567890123456789012345678901234567890123456789012345678901234 $;=join'?',sort@_,$;;grep{chop;(join'',sort split//)=~/^$;$/}<D> } __END__ =head1 SAMPLE OUTPUT ace aces acne act acted acute ad ads an and [SNIP] uneasy unsteady [SNIP]
    Historical Incantations:
    # 1 2 3 4 5 6 7 #234567890123456789012345678901234567890123456789012345678901234567890 +123456 $,=join'?',sort(@_),'';grep{chop;$;=join'',(sort(split//,$_));$;=~/^$, +$/}<D> $,=join'?',sort(@_),'';grep{chop;(join'',(sort(split//,$_)))=~/^$,$/}< +D> $,=join'?',sort(@_),'';grep{chop;(join'',sort split//)=~/^$,$/}<D> $;=join'?',sort@_,$;;grep{chop;(join'',sort split//)=~/^$;$/}<D> # with japhy's help... $;=join'?',sort@_;grep{chop;(join'',sort split//)=~/^$;?$/}<D> @_=sort@_;$"='?';grep{chop;(join'',sort split//)=~/^@_?$/}<D> # with dragonchild's help, and a 'perl -l' trick: @_=sort@_;$"='?';grep{(join'',sort split//)=~/^$\@_?$/}<D> # stealing a bit from gbarr @_=sort@_;$"='?';grep{(join'',sort/./g)=~/^@_?$/}<D>

    -Blake

      I hate to take credit for this 3-character reduction...
      $;=join'?',sort@_;grep{chop;(join'',sort split//)=~/^$;$/}<D>
      Why were you sorting $; as well?

      _____________________________________________________
      Jeff[japhy]Pinyan: Perl, regex, and perl hacker.
      s++=END;++y(;-P)}y js++=;shajsj<++y(p-q)}?print:??;

        The regex needs a '?' on the end... Its the difference between /^a?b?c$/ and /a?b?c?$/. Looking at it again, I only need to add one char to get it back though: 62 chars
        # 1 2 3 4 5 6 #2345678901234567890123456789012345678901234567890123456789012 $;=join'?',sort@_;grep{chop;(join'',sort split//)=~/^$;?$/}<D>
        Ah, but I can get it back with a little rearranging.... 61 chars
        # 1 2 3 4 5 6 #234567890123456789012345678901234567890123456789012345678901 @_=sort@_;$"='?';grep{chop;(join'',sort split//)=~/^@_?$/}<D>

        -Blake

        Why does neither of these return 'blade'?

        my @letters = qw(b a l d y a e y t);

        __PASTE__

        ~/perl_stuff> grep blade /usr/dict/words blade switchblade ~/perl_stuff> perl golf.pl aye baldy bay bayed beady bey by bye byte day delay dey dye lady lay lye y ye yea yet

        <a href="http://www.graq.co.uk">Graq</a>

      59 chars...
      # 1 2 3 4 5 6 7 #234567890123456789012345678901234567890123456789012345678901234567890 +123456 @_=sort@_;$"='?';grep{(join'',sort split//)=~m!^$/@_?$!}<D>

      ------
      We are the carpenters and bricklayers of the Information Age.

      Don't go borrowing trouble. For programmers, this means Worry only about what you need to implement.

        I like it... though the words returned now have trailing newlines. I can move one char from the sub to the command line options, thus improving the score by 1 under normal golf rules. 58 chars
        #!perl -l # 1 2 3 4 5 #234567890123456789012345678901234567890123456789012345678 @_=sort@_;$"='?';grep{(join'',sort split//)=~/^$\@_?$/}<D>

        -Blake

andye Re: "Countdown" (golf)
by andye (Curate) on Nov 30, 2001 at 18:27 UTC
    Following blakem's rules,
    # 1 2 3 #234567890123456789012345678901234567 $"='';grep{/^(([@_])(?!.*\2))+$/}<D>;
    37 characters! I'm pleased with my first try at golfing. ;)

    andy.

    PS stuffy, good choice of puzzle! There went my lunchtime.

    update: 36

    #234567890123456789012345678901234567 $"='';grep/^(([@_])(?!.*\2))+$/,<D>;
    update 2: Thanks dragonchild, 35 w/out the ;
    Hmm... you're right about the duplicate letters. I can't remember whether these appear on the t.v. show - I rather suspect they do.

    update, later:
    This cope with duplicates, but is a lot longer:

    # 1 2 3 4 5 6 7 + 8 #234567890123456789012345678901234567890123456789012345678901234567890 +12345678901 $"='';$n{$_}++for@_;grep/^((??{"([@_])"})(??{"(?!([^$1 ]*$1){$n{$1},}) +"}))+$/,<D>
    (you need to use re 'eval')
    I'd rather do:
    $"='';$n{$_}++for@_;grep/^(([@_])(??{"(?!([^$1 ]*$1){$n{$1},})"}))+$/, +<D>
    (the difference being that @_ is interpolated normally here), but for some reason this isn't allowed - I get back Eval-group in insecure regular expression in regex - no idea why, since I'm using re 'eval', and @_ surely can't be tainted?

    Going to dinner. andy.

      As always, removing the trailing semi-colon helps. :-)

      Excellent solution!

      Update: Of course (and this wasn't specified, so it's cool!) ... this won't work with duplicate letters. blakem's does, yours doesn't. I would suspect the gameshow, though it wouldn't say this, would never give dupes.

      ------
      We are the carpenters and bricklayers of the Information Age.

      Don't go borrowing trouble. For programmers, this means Worry only about what you need to implement.

        It can give dupes. In fact sometimes, the letters are so bad that the best the contestants can do is get a 4-letter word.

        I couldn't find the offical Countdown website on channel4.com. But there is more info about how the game is played here.

        Simon Flack ($code or die)
        $,=reverse'"ro_';s,$,\$,;s,$,lc ref sub{},e;$,
        =~y'_"' ';eval"die";print $_,lc substr$@,0,3;
      I can shorten your 36 non-duplicate-letter attempt by 5 chars with:
      # 1 2 3 #234567890123456789012345678901 grep/^(([@_])(?!.*\2))+$/x,<D>;
      I think this trick might be applicable to your others as well...

      Update: I'm still trying to grok your longer ones (re eval in golf... coool) and I'm uncovering some oddities:

      qw(a d d) ad add dad qw(a d) ad add <= wrong... but 'dad' got correctly skipped... I think add gets through because the 'd's are right next to each other
      Doubled letters (dd, tt, etc) are sneaking through... It looks like $n{'d'} needs to be temporarilly decremented when 'd' matches in the character class...

      -Blake

        I can shorten your 36 non-duplicate-letter attempt by 5 chars with: /x instead of $"=''

        Clever!

        I'm not surprised the re eval ones don't work properly - I was getting some strange results while working them out. Also I was becoming confused! ;)

        andy.

      I can't run your update using 5.6.0 on Solaris ... it says that there's an unmatched bracket...

      ------
      We are the carpenters and bricklayers of the Information Age.

      Don't go borrowing trouble. For programmers, this means Worry only about what you need to implement.

Re: "Countdown" (golf)
by gbarr (Monk) on Nov 30, 2001 at 21:11 UTC
    This progarm has been running for many years, over 20 I think.While I do not watch it on a regular basis, I have watched it quite a bit.

    The rules are you can only use the letters given and you can only use them as many times as they appear on the board.

    Given that I dont think any solution so far actually solve the problem correctly. Also the question was to only list those which are of the longest length.

    Here is my solution of 112

    my @letters = qw(d u n s c a e y t); open(D,"/usr/share/dict/words") or die $!; print f(@letters); sub f { # 1 2 3 4 5 #234567890123456789012345678901234567890123456789012345 my%h;$h{$_}++for@_;my@b;push @{$b[length]},$_ for grep{ # 6 7 8 9 0 1 #78901234567890123456789012345678901234567890123456789012 my%g=%h;$g{$_}--for/./g;!grep{$_<0}values%g}<D>;@{$b[-1]} }

    But I am sure someone will shorten it

      Modifying blakem's solution to do the longest yields 93 characters with
      @_=sort@_;$"='?';push@{$,[length]},$_ for grep{(join'',sort split//)=~ +m!^$/@_?$!}<D>;@{pop@,}

      Update: 92 characters.

      @_=sort@_;$"='?';push@{$,[length]},$_ for grep{(join'',sort split//)=~ +m!$/@_?$!}<D>;@{pop@,}

      Update2: 89 characters.

      @_=sort@_;$"='?';push@{$,[length]},$_ for grep{(join'',sort/./sg)=~m!$ +/@_?$!}<D>;@{pop@,}

      Update2: 88 characters.

      perl -l @_=sort@_;$"='?';push@{$,[length]},$_ for grep{(join'',sort/./sg)=~/$\ +@_?$/}<D>;@{pop@,}

      ------
      We are the carpenters and bricklayers of the Information Age.

      Don't go borrowing trouble. For programmers, this means Worry only about what you need to implement.

        wow, that junk after the push is hard on the eyes... ;-)

        I really like the /./sg trick, but why use the /s? Getting rid of that newline has been one of the big obstacles on the course. Stealing this trick (w/o the /s) lets me get rid of the $/ $\ nonsense, shortening my return-the-whole-list code to 52 chars!

        # 1 2 3 4 5 #234567890123456789012345678901234567890123456789012 @_=sort@_;$"='?';grep{(join'',sort/./g)=~/^@_?$/}<D>

        -Blake

        dragonchild
        your solution has the same problems as gbarr It only prints out the first of the longest words.

        Stuffy
        That's my story, and I'm sticking to it, unless I'm wrong in which case I will probably change it ;~)
        may be reproduced under the SDL
      gbarr
      I thought you were the first one to answer the call on all aspects, however, you have a flaw. It only returns the first instance of the longest word. If I change the letters to "d u n s c a e y z" it will only print out "ascend" It will not print out all the longest words.
      sub f { # 1 2 3 4 5 #234567890123456789012345678901234567890123456789012345 my%h;$h{$_}++for@_;my@b;push @{$b[length]},$_ for grep{ # 6 7 8 9 0 1 #789012345678901234567890123456789012345678901234567890123 my%g=%h;$g{$_}--for/./gi;!grep{$_<0}values%g}<D>;@{$b[-1]} }
      I added on stroke to make it case insensitive, but I'm not sure how to make it print out all possible answers rather then just the first one.

      Stuffy
      That's my story, and I'm sticking to it, unless I'm wrong in which case I will probably change it ;~)
      may be reproduced under the SDL
Re: "Countdown" (golf)
by chipmunk (Parson) on Dec 01, 2001 at 11:01 UTC
    I decided to write this as a one-liner that accepts the set of letters as the first argument.

    Here's my best solution, at 86 characters: perl -ne'INIT{$l=shift}$r=$L=$l;$r&&=$L=~s/$_//for/./g;$w[$r&&y///c].=$_}{print$w[-1]' That one assumes that there will be at least one match (otherwise it will print the entire word list), and it stores the entire word list in memory.

    This next solution avoids both those problems, at the cost of one character. 87 characters: perl -ne'INIT{$l=shift}$r=$L=$l;$r&&=$L=~s/$_//for/./g;$w[y///c].=$_ if$r}{print$w[-1]' Both solutions output all longest matches and work when the set of letters includes duplicates.

    Example usage: perl -ne'INIT{$l=shift}$r=$L=$l;$r&&=$L=~s/$_//for/./g;$w[y///c].=$_ if$r}{print$w[-1]' dunscaeyz wordlist

      If you reverse the order of the arguments you can use pop instead of shift to save two strokes....

      Update:

      This attempt is about the same length, though a few chars shorter in the actual -e argument. BTW, yours was a very *evil* script... unbalanced brackets in the -e of a -n? I didn't even realize that was legal, let alone useful! ;-)

      perl -aF// -ne'INIT{$l=pop}$L=$l.$/;$L=~s/$_// or$#F=0 for@F;$w[@F].=" +@F"}{print$w[-1]'

      -Blake

andye - a different tack Re: "Countdown" (golf)
by andye (Curate) on Dec 01, 2001 at 14:56 UTC
    76 characters, copes with dupes, returns a list of the longest words:
    sub f { # 1 2 3 4 5 6 7 #234567890123456789012345678901234567890123456789012345678901234567890 +1234567890 for(<D>){$n=0;$o=$_;for$c(@_){$n+=s/$c//};push@{$w[$n]},$o if/^$/;}@{$ +w[-1]} }
    Can probably be shortened by the expert golfers round here.

    andy.

      Nice, you managed to complete all 18 holes in the same number of strokes as it took me to do the back 9 with my first entry.... ;-)

      Although, I can trim a couple chars, it's no longer warnings-safe:

      # 1 2 3 4 5 6 7 #234567890123456789012345678901234567890123456789012345678901234567890 +12 for(<D>){$n=$o=$_;for$c(@_){$n+=s/$c//};/^$/&&push@{$w[$n]},$o}@{$w[-1 +]}

      -Blake


        This is untested, but the following can probably happen:

        Change the outer for loop to a map (1 character)
        Change the /^$/ to just $_ (2 characters)
        Change the @{$w[-1]} to @{pop@w} (1 character)
        Drop the semi-colon after the inner for loop (1 character)

        Which gives us:

        #234567890123456789012345678901234567890123456789012345678901234567890 +12 map{$n=$o=$_;for$c(@_){$n+=s/$c//}$_&&push@{$w[$n]},$o}<D>;@{pop@w}
        67 characters?
        jynx

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlmeditation [id://128568]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others perusing the Monastery: (3)
As of 2021-10-25 05:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My first memorable Perl project was:







    Results (89 votes). Check out past polls.

    Notices?