Squaring The Bishop

May 3, 2011

Our solution works in two phases. In the preparation phase, we store a dictionary in a vector of tries, one trie for each word-length. In the solution phase, we fill in the square left-to-right (equivalently, top-to-bottom), at each stage getting a list of all dictionary words that begin with the current prefix, keeping only those that lead to overall success. We will keeps words as a list of characters internally, converting from and to words only on input and output.

We begin with the function that inserts a word in a trie:

(define (insert cs t)
  (cond ((null? cs) t)
        ((assoc (car cs) t) => (lambda (x)
          (cons (cons (car cs) (insert (cdr cs) (cdr x))) (remove x t))))
        (else (cons (cons (car cs) (insert (cdr cs) '())) t))))

The tries are stored in a vector by length (yes, there are some very long words in some dictionaries!):

(define tries (make-vector 50 '()))

Before we add a word to a trie, we make sure that it contains only alphabetic characters (some dictionaries have words like 1st that contain non-alphabetic characters):

(define (valid? word)
  (let loop ((cs (string->list word)))
    (if (null? cs) #t
      (and (char-alphabetic? (car cs)) (loop (cdr cs))))))

Now we can write the function that inserts a dictionary into the tries:

(define (make-tries word-list)
  (with-input-from-file word-list
    (lambda ()
      (do ((word (read-line) (read-line)))
          ((eof-object? word))
        (when (valid? word)
          (let ((len (string-length word)))
            (vector-set! tries len
              (insert (string->list word)
                (vector-ref tries len)))))))))

You can use the dictionary at /usr/dict/words, but that dictionary is generally small and doesn’t provide a full set of inflections for each word (the dictionary may have square but not squared or squares). We use the dictionaries from the Moby project at http://icon.shef.ac.uk/Moby/mwords.html; the Scrabble dictionary with 113809 words works well:

(make-tries "moby.scrabble")

That completes the preparation phase. The solution phase has three functions, a solver and two auxiliary functions: prefs finds all the dictionary words with a specified prefix and nths returns a list of the nth item in each list in a list of lists. We’ll start at the end, with the solver:

(define (square word)
  (let* ((len (string-length word))
         (ss (let* ((ss (list (string->list word)))
                     (ps (prefs len (nths 1 ss))))
                (map (lambda (p) (append ss (list p))) ps))))
    (let loop ((n 2) (ss ss))
      (if (= len n)
          (map (lambda (s) (map list->string s)) ss)
          (loop (+ n 1)
                (mappend (lambda (s)
                           (let ((ps (prefs len (nths n s))))
                             (map (lambda (p) (append s (list p)))
                                  ps)))
                         ss))))))

Let’s watch what happens, slowly, on the input (square "dean"). Len is 4, ss is initially ((#\d #\e #\a #\n)), and ps, the list of words that starts with #\e, is ((#\e #\y #\r #\y) (#\e #\y #\r #\e) (#\e #\y #\r #\a)(#\e #\a #\r #\n) (#\e #\a #\r #\l) (#\e #\a #\c #\h)); note that nths starts at 1, not 0, because strings are indexed from 0, but the 0’th string is the input word. Then map forms a new ss that looks like (((#\d #\e #\a #\n) (#\e #\y #\r #\y)) ((#\d #\e #\a #\n) (#\e #\y #\r #\e))((#\d #\e #\a #\n) (#\e #\a #\r #\l)) ((#\d #\e #\a #\n) (#\e #\a #\c #\h))) that pairs (#\d #\e #\a #\n) with each word beginning with #\e.

Now we enter the main loop. N starts at 2 and counts up until it reaches the end of the word, when the recursion stops and the result is returned, with lists of characters converted to words. Otherwise, each recursive step computes a new ss in which each element of the current ss is combined with each word that begins with the proper prefix. At the end of the second step, for instance, ss looks like (((#\d #\e #\a #\n) (#\e #\y #\r #\y) (#\a #\r #\y #\l)) ((#\d #\e #\a #\n) (#\e #\y #\r #\y) (#\a #\r #\v #\o))((#\d #\e #\a #\n) (#\e #\a #\c #\h) (#\a #\c #\e #\s)) ((#\d #\e #\a #\n) (#\e #\a #\c #\h) (#\a #\c #\e #\d))).

We could have used explicit backtracking to recursively run up and down the list of possible words at each stage. Instead, we use a technique that Phil Wadler calls the “list of successes” in his paper “How to replace failure by a list of successes,” in Proceedings of the conference on functional programming languages and computer architecture, Nancy, France, 1985, pages 113–128. At each stage, instead of backtracking, we extend the accumulating solution with the possibilities that survive to the next stage; those that fail become null and are swept out by the append that is hidden inside the mappend function.

Now we can go back and fill in the details. Here is nths:

(define (nths n xss)
  (map (lambda (xs) (list-ref xs n)) xss))

Prefs is more interesting. It runs down the list of characters given as the prefix, then calls expand to fetch all possible words in the rest of the trie beyond that point:

(define (prefs n cs)
  (let loop ((cs cs) (ps '()) (t (vector-ref tries n)))
    (cond ((null? cs) (expand ps t))
          ((assoc (car cs) t) => (lambda (x)
            (loop (cdr cs) (cons (car cs) ps) (cdr x))))
          (else '()))))

(define (expand ps t)
  (if (null? t) (list (reverse ps))
    (mappend (lambda (x) (expand (cons (car x) ps) (cdr x))) t)))

And that’s it. Here is some sample output:

> (square "praxis")
(("praxis" "regent" "agenda" "xenial" "indaba" "stalag")
  ("praxis" "regent" "agency" "xenial" "incase" "stylet")
  ("praxis" "regent" "agency" "xenial" "incase" "styles")
  ("praxis" "regent" "agency" "xenial" "incase" "styler")
  ("praxis" "regent" "agency" "xenial" "incase" "styled")
  ("praxis" "regent" "agency" "xenial" "incage" "stylet")
  ("praxis" "regent" "agency" "xenial" "incage" "styles")
  ("praxis" "regent" "agency" "xenial" "incage" "styler")
  ("praxis" "regent" "agency" "xenial" "incage" "styled"))
> (time (length (square "bishop")))
(time (length (square "bishop")))
    9 collections
    296 ms elapsed cpu time, including 125 ms collecting
    1000 ms elapsed real time, including 0 ms collecting
    37377352 bytes allocated, including 52310008 bytes reclaimed
122

And here is one of the 122 outputs from (square "bishop") (osteal means “of or pertaining to bone”):

B I S H O P
I M P O S E
S P O R T S
H O R N E T
O S T E A L
P E S T L E

With the full list of 354984 Moby words, we find 2590 squares for “bishop” in about 2.5 seconds; Babbage would have been amazed. We used mappend from the Standard Prelude. You can see all the pieces assembled at http://programmingpraxis.codepad.org/IfouARKz.

By the way, I wanted to write square like this:

(define (square word)
  (let ((len (string-length word)))
    (let loop ((n 1) (ss (list (string->list word))))
      (if (= len n) (map (lambda (s) (map (list->string s)) ss))
        (loop (+ n 1)
              (mappend (lambda (s)
                         (let ((ps (prefs len (nths n s))))
                           (map (lambda (p) (append s (list p))) ps)))
                       ss))))))

But that doesn’t work, because the types don’t come out straight. Do you see why?

About these ads

Pages: 1 2

14 Responses to “Squaring The Bishop”

  1. [...] today’s Programming Praxis exercise, our goal is to write a program that can create word squares. [...]

  2. My Haskell solution (see http://bonsaicode.wordpress.com/2011/05/03/programming-praxis-squaring-the-bishop/ for a version with comments):

    import qualified Data.ByteString.Char8 as B
    import qualified Data.List.Key as K
    import qualified Data.Map as M
    import qualified Data.Trie as T
    
    loadWords :: IO (M.Map Int (T.Trie Int))
    loadWords = fmap (M.fromList . map (\(w:ws) -> (snd w, T.fromList (w:ws))) .
                      K.group snd . K.sort snd . map (\w -> (w, B.length w)) .
                      B.words) $ B.readFile "words.txt"
    
    findWords :: Int -> String -> M.Map Int (T.Trie a) -> [B.ByteString]
    findWords l prefix = T.keys . T.submap (B.pack prefix) . (M.! l)
    
    square :: String -> M.Map Int (T.Trie a) -> [[B.ByteString]]
    square word ds = f 1 [B.pack word] where
        f n ws = if n == length word then [ws] else 
                 (\w -> f (n + 1) (ws ++ [w])) =<<
                 findWords (length word) (map (`B.index` n) ws) ds
    
    main :: IO ()
    main = do print . square "bonsai" =<< loadWords
              print . (== 122) . length . square "bishop" =<< loadWords
    
  3. arturasl said

    Solution in java: github.
    Simple run (squares for word “arthur” :D ):

    [[ ARTHUR, REWIRE, TWINGE, HINGES, URGENT, REESTS ], [ ARTHUR, REZONE, TZURIS, HORSTE, UNITED, RESEDA ]]
    2
    
  4. Graham said

    My Python solution.
    It’s not quite as quick as I might like, and I could do without the overloading of
    + via sum… Also, I wanted to make sure my solutions
    were correct without going through them by hand, so I wrote a recursive check
    at the end.

  5. Graham said

    Apologies for messing up the linebreaks in my comment

  6. Rainer said

    My try in REXX:

    /* Datei von http://icon.shef.ac.uk/Moby/mwords.html */
    file = ‘354984si.ngl.txt’

    list. = ”
    llen. = 0
    solno = 0
    print = ‘0’
    call word_square ‘DEAN’
    say solno ‘Solutions for DEAN’

    list. = ”
    llen. = 0
    solno = 0
    print = ‘1’
    call word_square ‘BISHOP’
    say solno ‘Solutions for BISHOP’

    exit

    word_square:
    parse arg wort
    wl = length(wort)
    do while lines(file)
    data = strip(upper(linein(file)))
    if length(data) \= 4 then iterate
    first = substr(data,1,1)
    p = pos(first,substr(wort,2))
    if p == 0 then iterate
    list.p = list.p data
    llen.p = llen.p + 1
    end
    do a = 1 to llen.1
    worta = word(list.1,a)
    do b = 1 to llen.2
    wortb = word(list.2,b)
    do c = 1 to llen.3
    wortc = word(list.3,c)
    do d = 1 to max(llen.4,1)
    wortd = word(list.4,d)
    do e = 1 to max(llen.5,1)
    worte = word(list.5,e)
    call check_worte wort worta wortb wortc wortd worte
    end
    end
    end
    end
    end
    return

    check_worte: procedure expose solno print
    parse arg w1 w2 w3 w4 w5 w6
    wl = length(w1)
    w.1 = w1; w.2 = w2; w.3 = w3; w.4 = w4; w.5 = w5; w.6 = w6
    m. = ”
    do i = 1 to 6
    do j = 1 to 6
    m.i.j = substr(w.i,j,1)
    end
    end
    do i = 1 to 6
    do j = 1 to 6
    if m.i.j \= m.j.i then return
    end
    end
    solno = solno + 1
    if print == ‘1’ then do
    say ‘Solution #’solno
    do i = 1 to 6
    if strip(w.i) \= ” then,
    say m.i.1 m.i.2 m.i.3 m.i.4 m.i.5 m.i.6
    end
    say copies(‘-‘,50)
    end
    return

    /*
    3633 Solutions for DEAN
    0 Solutions for BISHOP
    */

  7. Rainer said

    Sorry, missed the formatting

    file = '354984si.ngl.txt'
    
    list. = ''
    llen. = 0
    solno = 0
    print = '0'
    call word_square 'DEAN'
    say solno 'Solutions for DEAN' 
    
    list. = ''
    llen. = 0
    solno = 0
    print = '1'
    call word_square 'BISHOP'
    say solno 'Solutions for BISHOP'
    
    exit
    
    word_square: 
        parse arg wort 
        wl = length(wort)
        do while lines(file)
            data = strip(upper(linein(file)))
            if length(data) \= 4 then iterate
            first = substr(data,1,1)
            p = pos(first,substr(wort,2))
            if p == 0 then iterate
            list.p = list.p data
            llen.p = llen.p + 1
        end
        do a = 1 to llen.1
            worta = word(list.1,a)
            do b = 1 to llen.2
                wortb = word(list.2,b)
                do c = 1 to llen.3
                    wortc = word(list.3,c)
                    do d = 1 to max(llen.4,1)
                        wortd = word(list.4,d)
                        do e = 1 to max(llen.5,1)
                            worte = word(list.5,e)
                            call check_worte wort worta wortb wortc wortd worte
    		    end
                    end 
    	    end
            end                 
        end
        return
    	
    check_worte: procedure expose solno
        parse arg w1 w2 w3 w4 w5 w6 
        wl = length(w1)
        w.1 = w1; w.2 = w2; w.3 = w3; w.4 = w4; w.5 = w5; w.6 = w6
        m. = ''
        do i = 1 to 6
            do j = 1 to 6
                m.i.j = substr(w.i,j,1)
            end
        end
        do i = 1 to 6
            do j = 1 to 6
                if m.i.j \= m.j.i then return
            end
        end
        solno = solno + 1
        if print == '1' then do
            say 'Solution #'solno	
            do i = 1 to 6
                if strip(w.i) \= '' then,
                    say m.i.1 m.i.2 m.i.3 m.i.4 m.i.5 m.i.6
            end
            say copies('-',50)
        end
        return 
    
  8. Axio said

    The latin one is very interesting: it is also a palindrome when lines are concatenated.
    It’s an easy constraint though, as far as solving algorithmics is concerned: each word and its reverse just have in the dictionary…

  9. I began by compiling a file with all the six letter words (ignoring anything that wasn’t A-Z) from the dictionary in /usr/share/dict/words. I then spent five minutes writing the first version of this which was brute force, set it running, and then revised it to create and use a prefix table. The second version was completed five minutes later, while the first was still struggling in finding the tenth or so match. This program identifies 15,533 valid squares in about six and a half seconds on my (pretty fast) HP workstation.

    #!/usr/bin/env python
    
    start = "BISHOP"
    
    words = map(lambda x : x.strip(), open("6words").readlines())
    
    ptab = { }
    
    for w in words:
        for x in range(1, len(w)):
            ptab[w[:x]] = ptab.get(w[0:x], []) + [w]
    
    
    def check(good, n, new):
        for i in range(n):
            if good[i][n] != new[i]:
                return False
        return True
    
    def search(start, n):
        if n == 6:
            print start
            return
        prefix = ''.join([start[i][n] for i in range(n)])
        for w in ptab.get(prefix, []):
            if check(start, n, w):
                search (start + [w], n+1)
    
    def findsquare(start):
        good = [ start ] 
        search(good, 1)
    
    findsquare(start)
    
  10. Jussi Piitulainen said

    I wrote a Python3 script to write me the source code for the Prolog database of
    the words – trie(C, W) to get words that begin with C. This is ./dictate.py (sans #!):

    from sys import stdin
    
    def select(word):
        for k in range(len(word)):
            yield word[:k], word[k:k + 1], word[k + 1:]
    
    nodes = dict()
    
    for word in stdin:
        word = word.strip()
        for before, at, after in select(word):
            if before not in nodes: nodes[before] = set()
            nodes[before].add((at, after==''))
    
    for before in nodes:
        for at, end in nodes[before]:
    	print(('trie{b}({a},[{a}]).' if end
                   else 'trie{b}({a},[{a}|T]) :- trie{b}{a}(_,T).')
                  .format(b=before, a=at))
    

    Then I used it with SCOWL-7.1 word lists in Bash like this, taking only six letter words
    for this task, though a variable length trie should work all right:

    ./mk-list british 60 | grep -Ex '[a-z]{6}' | ./dictate.py | LC_ALL sort > british60.pl
    

    The resulting trie source code has a little over 22k lines like so:

    trie(a,[a|T]) :- triea(_,T).
    trie(b,[b|T]) :- trieb(_,T).
    ...
    triezygo(t,[t|T]) :- triezygot(_,T).
    triezygot(e,[e]).
    

    The Prolog program to check or fill in a square represents the square as a list of lists,
    and it just says that the square is its own transpose and each row is in the trie.

    square(Words) :- transpose(Words, Words), words(Words).
    
    transpose([R|Rs], [C|Cs]) :- slice([R|Rs], C, Ts), transpose(Ts, Cs).
    transpose([[]|_], []).
    transpose([], []).
    
    slice([[A|As]|Rs], [A|Hs], [As|Ts]) :- slice(Rs, Hs, Ts).
    slice([], [], []).
    
    words([W|Ws]) :- word(W), words(Ws).   words([]).
    
    word([C|Cs]) :- trie(C, [C|Cs]).
    

    The transpose/2 predicate works properly when the square (it can be oblong) has a definite size, which is a nuisance to write by hand every time, so I wrote an auxiliary to establish the size, and another to display the results nicely:

    size(Words, Ht, Wd) :- length(Words, Ht), lengths(Words, Wd).
    
    lengths([Word|Words], Wd) :- length(Word, Wd), lengths(Words, Wd).
    lengths([], Wd).
    
    display([Word|Words]) :- write(Word), nl, display(Words).
    display([]) :- nl.
    

    Then the solutions (none of them in this word list) having [b,i,s,h,o,p] as the first row
    can be found and displayed so:

    ?- size(A,6,6), nth0(0,A,[b,i,s,h,o,p]), square(A), display(A), fail.
    

    This does more. It can be asked for squares that contain a word as any row. Still none for [b,i,s,h,o,p] in this list (plenty in a larger list) but there are two for [d,i,s,p,e,l]:

    ?- size(A,6,6), member([d,i,s,p,e,l],A), square(A), display(A), fail.
    [d, i, s, p, e, l]
    [i, m, p, a, l, a]
    [s, p, i, r, i, t]
    [p, a, r, a, d, e]
    [e, l, i, d, e, s]
    [l, a, t, e, s, t]
    
    [m, a, d, r, a, s]
    [a, p, i, e, c, e]
    [d, i, s, p, e, l]
    [r, e, p, u, t, e]
    [a, c, e, t, i, c]
    [s, e, l, e, c, t]
    
    false.
    

    I don’t know what [m,a,d,r,a,s] and [a,c,e,t,i,c] mean, but then I didn’t know
    [o,s,t,e,a,l] either. And I wonder if this problem could be done nicely in SQL.

  11. Jussi Piitulainen said

    Sorry. Typo in the command line that sorted the trie source code. The last command should, of course, be:

    LC_ALL=C sort
    

    The setting of LC_ALL to C is so that it does not ignore parentheses or anything like that. Prolog wants the clauses of a predicate together by default. Sorry again. As if the entry was not long enough already.

  12. Mike said

    Here’s my first take. Basically, does a bread-first search of the solution space.

    Note: I couldn’t open the moby word list from the link in the problem. But I was able to get it from Project Gutenberg.

    from collections import defaultdict
    
    def wordsquare(first_word):
        size = len(first_word)
    
        prefix_table = defaultdict(list)
        first_letters = set(first_word)
        with open("mword10/single.txt", "rt") as f:
            for line in f:
                word = line.strip().strip('%')
                
                if len(word) == size and word[0] in first_letters:
                    for n in range(1, size):
                        prefix_table[word[:n]].append(word)
                
        candidates = [[first_word]]
        for ndx in range(1, size):
            tmp = []
            for square in candidates:
                prefix = ''.join(w[ndx] for w in square)
                tmp.extend(square + [word] for word in prefix_table[prefix])
    
            candidates = tmp
    
        return candidates
    
  13. [...] this one was just neat. Based on an older post from Programming Praxis filed under Word Games, the idea is to find a set of words with very [...]

  14. JP said

    That was fun. :) I wrote up my solution in Racket, making sure to take advantage of the excellent for/listmacro. For the dictionary, I implemented a trie structure based on hashtables, which was really useful also (and particularly useful for working with prefixes).

    Dictionary tries in Racket
    Squaring the Bishop

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Follow

Get every new post delivered to your Inbox.

Join 630 other followers

%d bloggers like this: