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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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:??; | [reply] [Watch: Dir/Any] [d/l] |
|
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
~/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> | [reply] [Watch: Dir/Any] [d/l] |
|
|
|
# 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. | [reply] [Watch: Dir/Any] [d/l] |
|
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
| [reply] [Watch: Dir/Any] [d/l] |
andye Re: "Countdown" (golf)
by andye (Curate) on Nov 30, 2001 at 18:27 UTC
|
# 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. | [reply] [Watch: Dir/Any] [d/l] [select] |
|
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.
| [reply] [Watch: Dir/Any] |
|
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;
| [reply] [Watch: Dir/Any] |
|
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
| [reply] [Watch: Dir/Any] |
|
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.
| [reply] [Watch: Dir/Any] |
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
| [reply] [Watch: Dir/Any] [d/l] |
|
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. | [reply] [Watch: Dir/Any] [d/l] [select] |
|
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
| [reply] [Watch: Dir/Any] [d/l] |
|
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
| [reply] [Watch: Dir/Any] |
|
|
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 | [reply] [Watch: Dir/Any] [d/l] |
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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 | [reply] [Watch: Dir/Any] [d/l] |
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.
| [reply] [Watch: Dir/Any] [d/l] |
|
# 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
| [reply] [Watch: Dir/Any] [d/l] |
|
#234567890123456789012345678901234567890123456789012345678901234567890
+12
map{$n=$o=$_;for$c(@_){$n+=s/$c//}$_&&push@{$w[$n]},$o}<D>;@{pop@w}
67 characters?
jynx | [reply] [Watch: Dir/Any] [d/l] |
|