Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

(Golf) Word squares

by japhy (Canon)
on Aug 13, 2001 at 20:44 UTC ( #104481=perlmeditation: print w/replies, xml ) Need Help??

Word squares are like really simple crossword puzzles. There are no black squares, the grid is a square, and the "down" clues are the same as the "across" clues.

So, given a list of words, construct a word square out of them. Here is an example:

division of a road: _ _ _ _ a location: _ _ _ _ in proximity to: _ _ _ _ hearing organs: _ _ _ _
The solution:
L A N E
A R E A
N E A R
E A R S
So, given some list of strings, return the strings in the order they would appear (down or across) in the grid. My solution uses two functions, and thus, I have decided that character count will include the "sub ...".
#23456789_123456789_123456789_123 sub Q{my$j=pop;my@l=map$$_[$j],@_ ;for(@_){return"@$_",Q(@_,++$j)if "@{[sort@$_]}"eq"@{[sort@l]}"}()} sub S{Q map([split//],@_),$"=""}
My code is (updated, thanks to abstracts) 131 characters.

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

Replies are listed 'Best First'.
Re: (Golf) Word squares
by abstracts (Hermit) on Aug 14, 2001 at 00:05 UTC
    Update5: Thanks larryk for the suggestion, 77 now
    sub Z{ @_=@l=sort{.5<=>rand}@_;join('',reverse@l)eq(join'',map{map{chop}@l}@l +)?@_:&Z }

    Update4: Okay, last update, sorry (87 now)

    sub Z{ @_=@l=map{splice@_,rand@_,1}@_;join('',reverse@l)eq(join'',map{map{cho +p}@l}@l)?@_:Z(@_) }

    Update3:Okay, so I'm bad at golf :-) (now at 98)

    sub Z{ for(;;){@_=@l=map{splice@_,rand@_,1}@_;return@_ if join('',reverse@l)e +q join'',map{map{chop}@l}@l} }

    Update2: Using for(;;) instead of while(1) -- count = 101;

    sub Z{ for(;;){@l=map{splice@_,rand@_,1}@_;@_=@l;return@_ if join('',reverse@ +l)eq join'',map{map{chop}@l}@l} }

    Original:

    Hello

    Here is my shot at 102 using permutation trial and error, enjoy

    my @ar = qw/NEAR LANE EARS AREA/ ; # @ar = qw/LINGO MILLS SMOCK IDIOM LOGIC/; print "$_\n" for Z(@ar); sub Z{ while(1){@l=map{splice@_,rand@_,1}@_;@_=@l;return@_ if join('',reverse +@l)eq join'',map{map{chop}@l}@l} }

    Aziz,,,

    Update: Added Mills Lingo :-)

      updates removed: my updates (which I have removed from this post) didn't work!

      ------
      @_=@l=sort{rand cmp rand}@_;join('',reverse@l)eq(join'',map{map{chop}@ +l}@l)?@_:&Z #81
         larryk                                          
      perl -le "s,,reverse killer,e,y,rifle,lycra,,print"
      annoyingly, "line" and "ikea" fit as well in the example...
Re: (Golf) Word squares
by Cirollo (Friar) on Aug 13, 2001 at 21:18 UTC
    This assumes that your list of words can fit together to form such a square. Obviously there is going to be a finite number of such squares, and I would think that it wouldn't be an incredibly huge number, since it's fairly difficult to come up with a set of words that works (and it gets even harder if you want a larger square).

    It would be interesting to see a program that crunches through a word list (such as /usr/share/lib/dict/words) and 'discovers' combinations of words that can be made into word squares.

      Actually they are more numerous than you might think... I played around with them a looong time ago, and came up with this one for my last name 'Mills'.

      • Mills' Idiom: "Lingo, Logic, Smock."
        M I L L S
        I D I O M
        L I N G O
        L O G I C
        S M O C K
      Any suggestion as to what "Lingo, Logic, Smock" might mean?

      I'll update this node with the code I used, as soon as I can find it.

      -Blake

      Well, the idea is you're given a set of words that will fit into such a grid.

      As for your request, I think it wouldn't be too challenging to write such a program. I shall try now.

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

        Actually, I started writing a program to do just that a few months ago. I don't think I ever finished it, and I think now it's gathering dust in the rather large ~/scripts playground on my laptop.

        I'll have to try to dig it up when I get home, unless you post your better, faster and more elegant solution first. :)

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (6)
As of 2023-02-09 11:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer not to run the latest version of Perl because:







    Results (44 votes). Check out past polls.

    Notices?