Puzzle Pong I - Generating All Possible 4x4 Crosswords

bash

ACTS --> (across) acts, lore, idea, teem
LORE     ( down ) alit, code, tree, seam
IDEA
TEEM

haskell

import qualified Control.Monad   as N (forM)
import qualified Data.Maybe      as B (isJust, isNothing, catMaybes)
import qualified Data.Char       as C (isAsciiLower)
import qualified Data.Function   as F (on)
import qualified Data.List       as L (all, nub, groupBy, intercalate)
import qualified Data.List.Split as L (chunksOf)
import qualified Data.Map.Strict as M (Map, insert, empty, unions, findWithDefault)
import qualified Language.Words  as W (allStringWords)

-- A box can either have a single character or nothing. Using the Maybe monad
-- here turned out to be a really useful decision, with functions like isJust
-- and catMaybes doing the heavy lifting for the most part.
type Box = Maybe Char

-- A grid is just a list of boxes. This was originally implemented as a
-- `Data.Matrix Maybe Char`, but it turned out to be very slow compared to a
-- stupid list. That said, I ended up having to rewrite the getters and setters,
-- as seen below.
type Grid = [Box]

-- One issue I ran into a lot was confusing row and col indices. Defining a
-- custom datatype akin to Either helped solve this -- it's a lot harder to pass
-- a Row index as a Column if the compiler catches it ;)
data Idx a = Row a | Col a deriving (Eq, Ord, Show)

-- This is the precomputed dictionary discussed above -- it maps Strings (like 
-- "a" or "abc") to list of chars (printed as `['a', 'e', 'i'...]`)
type Paths = M.Map String [Char]

-- This is the width of the grid. Can be changed, but it would be a hassle to
-- extricate into a command-line argument or even a main-block variable.
n = 4

-- Here begins the set of getters and setters I mentioned above. You can see
-- that while gridSet takes an element to insert, a tuple of the row and column
-- at which to insert it, the original grid, and returns the resultant grid. The
-- _type_ of `Row r` and/or `Col c` are `Idx Int`, since they are of type `Idx`, 
-- which is just a wrappeer for the `Int` index itself. By naming their types on
-- the left-hand side of the definition, we can use `r` and `c` in the
-- computation without unwrapping.
gridSet :: Num a => Char -> (Idx Int, Idx Int) -> Grid -> Grid
gridSet el (Row r, Col c) g = take i g ++ [Just el] ++ drop (i+1) g
  where i = (r-1)*n + (c-1)

-- Another trick with `Idx` -- we can pattern-match on the type, returning one
-- computation for the nth row of a grid, and another for the mth column.
-- This uses Data.List.chunksOf, which I', a big fan of.
gridGet :: Grid -> Idx Int -> [Box]
gridGet g (Col x) = map head $ L.chunksOf n $ drop (x-1) g
gridGet g (Row x) = take n $ drop (n*(x-1)) g

-- This is a pretty-printer for a grid -- it unwraps a list of [Maybe Char]s,
-- replacing Nothings with _; then it segments that into chunks of 4 and
-- recombines them with "\n".
gridPrint :: Grid -> String
gridPrint xs = L.intercalate "\n" $ L.chunksOf n $ unwrap xs
  where unwrap []            = ""
        unwrap (Just x : xs) =  x  : unwrap xs
        unwrap (Nothing: xs) = '_' : unwrap xs

-- This is a foldr implementing `gridSet` across a list of elements and a list
-- of (Row, Col) pairs. By zipping the chars and locs and `uncurry`ing them, we
-- avoid having to write something like  
-- gridWrite []     _      g = g
-- gridWrite (c:cs) (l:ls) g = gridSet c l $ gridWrite cs ls g
gridWrite :: String -> [(Idx Int, Idx Int)] -> Grid -> Grid
gridWrite cs ls g = foldr (uncurry gridSet) g $ zip cs ls

-- All the words we care about. There are 98k words in
-- Language.Words.allStringWords, probably taken from usr/share/dict/words. Of
-- those, 64 are lowercase ascii, and 2.3k are four lettersr long.
allWords :: [String]
allWords = filter (\x -> length x == n) 
         $ filter (L.all C.isAsciiLower) W.allStringWords

-- Here's where the magic happens. dictMake i creates a Paths, where:
-- type Paths = Map String [Char]
-- but only where the keys are of length `i`. We call it a few types and 
-- `M.unions` them together later on to commbine them into one Map in memory.
dictMake :: Int -> Paths
dictMake len = foldr (\xs -> M.insert (key xs) (val xs)) M.empty nglyphs
  where key     = take len . head
        val     = S.fromList . map (head . drop len)
        nglyphs = L.groupBy ((==) `F.on` take len) $ map (take $ len+1) allWords
-- Working backwards, assuming len = 2 for this example:
--                      allWords ~ ["abed", "abet", "able", "ably", "abut"...]
--   map (take $ len+1) allWords ~ ["abe", "abe", "abl",  "abl", "abu"...] 
-- L.groupBy ((==) `F.on` take len) $ map (take $ len+1) allWords 
--                               ~ [["abe", "abl"..], ["ace", "ace", "ach"]..]
-- from this list, we can map `key`, which gets just the first `len` letters
--                                   from the first item in each list, and
--                            `val`, which gets the list of remaining letters.
--                               ~ Map ["ab"] -> ['e','l'..]
--                                     ["ac"] -> ['e','h'..]
-- Then we fold this `(\xs -> M.insert (key xs) (val xs))` 
--              over `nglyphs`, with
--              base `M.empty`.


-- If the data being intersected is complex and needs to be sorted and nubbed,
--  treating the items as Sets is often efficient. That's why the following 
-- function, `children`, used to do a Set intersection, and `paths` used to 
-- contain values  of `S.Set Char`. 
-- 
-- But it turns out that the values in `Paths` comes pre-sorted and pre-nubbed
-- by virtue of its origins in `W.allStringWords`. So we don't want the overhead
-- of creating, comparing, and toList-ing `Data.Set`s. We don't even want the
-- overhead of `Data.List.intersection`, which sorts the arrays before taking
-- their intersection. For that reason, we implement `intersect` ourselves,
--  below.
intersect :: [Char] -> [Char] -> [Char]
intersect [] _ = []
intersect _ [] = []
intersect (a:as) (b:bs)
  | a == b = a : intersect as bs
  | a < b  = intersect as (b:bs)
  | a > b  = intersect (a:as) bs

-- `children` accepts a `paths` dictionary to hold inline, which end up being
-- fairly efficient -- I believe the compiler notices it is unchanged between
-- calls of `children` and makes it something like a global.
-- 
-- Anyway, `children` accepts a `paths` dictionary and a grid and returns the
-- possible child grids, as decribed above. This is just a list comprehension
-- where the location of the next blank is described by `(r,c)`, which zips the
-- grid with the locations of its squares and drops filled squares until we get
-- the location of the first blank.
--
-- Additionally, we find the `poss`ible next letters by taking the intersection
-- of the two `setValid` valid lists along the `c` column and `r` row indices,
-- where `setValid` utilized `Data.Maybe.catMaybes` to strip the `Nothing`s from
-- a list of `[Maybe Char]`s, and uses a macro'd `Data.Map.findWithDefault`
-- titled `nextIn`. to find it in the `paths` map.
children :: Paths -> Grid -> [Grid]
children p g = [ gridSet l (r,c) g | l <- poss g ]
  where (r,c) = snd $ head $ filter (B.isNothing . fst) $ zip g indices
        indices  = [ (Row i, Col j) | i<-[1..n], j<-[1..n] ]
        nextIn s = M.findWithDefault [] s p
        poss g   = intersect (setValid c) (setValid r)
          where setValid = nextIn . B.catMaybes . gridGet g

-- We want to start with grids with filled top rows and leftmost columns. We use
-- `gridWrite` from before to write full words along lists of locations,
-- described by `firstRow` and `firstColumn`. We write these into a `blank` grid
-- of sixteen `Nothing`s. This, too, is a list comprehension, which is
-- convenient for applying the restrictions which make our grids unique.
--
-- Specifically, we want the top and left words to be different, have the same 
-- first letter, and not appear again in the opposite configuration later on.
-- Luckily, we can compare `wa < wb` to make sure this holds.
seeds :: [Grid]
seeds = [ gridWrite wa firstRow $ gridWrite wb firstCol blank
        | wa <- allWords , wb <- allWords , wa < wb, wa /= wb, head wa == head wb
        ]
  where firstRow = [ (Row 1, Col x) | x <- [1..n] ]
        firstCol = [ (Row x, Col 1) | x <- [1..n] ]
        blank    = replicate (n^2) Nothing

-- As usual, we utilize the `until cond fn seed` pattern to apply `fn` to `seed` 
-- over and over ([x, f(x), f(f(x))..]) until one of the elements fulfills 
-- `cond`. In this case, we define `paths` right here, inline, as the union of
-- the `dictMake` dicts for a range of integers from 1 til one less the side
-- length.
--
-- Additionally, we `filter` our answer to make sure none of the grids have
-- repeating words. Eliminating these grids with duplicate words at the very end
-- is more efficient than whittling down the `paths` dictionary recursively. We
-- build `noRepeats` with `wordsIn`, which gets each row and column with
-- `gridGet`, builds a list, nubs it, and inspects its length.
grids = filter noRepeats 
      $ until (B.isJust . last . head) (concatMap $ children paths) seeds
  where paths       = M.unions $ map dictMake [1..(n-1)]
        noRepeats g = 2*n == length (wordsIn g)
        wordsIn g   = L.nub 
                    $ map (gridGet g)
                    $ concatMap (\x -> [Row x, Col x])
                    [1..n]

-- And that's it! Initially, we just want to print the number of grids, but 
-- we may do more interesting things with `grids` later.
main = print $ length $ grids

bash

j@mes $ ghc -O2 words.hs
[1 of 1] Compiling Main             ( words.hs, words.o )
Linking words ...

j@mes $ time ./words
686739

real	1m1.138s
user	1m0.810s
sys	0m0.303s

bash

j@mes $ ghc -prof -fprof-auto -rtsopts -O2 words.hs
[1 of 1] Compiling Main             ( words.hs, words.o )
Linking words ...

j@mes $ time ./words +RTS -p
686739

real	2m8.759s
user	2m8.277s
sys	0m0.470s

bash

  Sun May 28 00:13 2017 Time and Allocation Profiling Report  (Final)

     words +RTS -p -RTS

  total time  =      107.52 secs   (107523 ticks @ 1000 us, 1 processor)
  total alloc = 134,700,416,432 bytes  (excludes profiling overheads)

COST CENTRE            MODULE                     %time %alloc

children.nextIn        Main                        20.8    0.0
children.(...)         Main                        13.1   14.1
gridGet                Main                        11.0   16.8
children               Main                        10.0    6.1
gridSet                Main                         9.4   20.8
build                  Data.List.Split.Internals    7.7    9.9
chunksOf               Data.List.Split.Internals    7.1   18.8
grids                  Main                         5.7    2.6
children.poss.setValid Main                         5.5    6.3
intersect              Main                         5.3    1.8
grids.wordsIn          Main                         1.9    1.2
children.poss          Main                         1.4    1.4

0.062s    0.164s     54.0s

ABED      ABACI      ABBESS
BLUR      BOWED      SEESAW
EERY      AXIAL      CATTLE
TWOS      SENSE      ERRATA
          EDGED      NEATER
                     DRYERS

DRAB      WARD      DRAW      BARD
RAGA      AJAR      RAJA      AGAR
AJAR      RAGA      AGAR      RAJA
WARD      DRAB      BARD      DRAW

DRAB  DRAB  DRAB  DRAB  DRAW  DRAW  TRAM  TRAM  STEP  STEP
RAGA  RAJA  RAGA  RAJA  RAGA  RAJA  RAGA  RAJA  TIDE  TIME
AJAR  AGAR  AJAR  AGAR  AJAR  AGAR  AJAR  AGAR  EMIT  EDIT
WARD  WARD  YARD  YARD  YARD  YARD  PART  PART  WETS  WETS

haskell

main = Control.Monad.forM grids 
     $ \g -> appendFile "grids.txt" $ gridPrint g ++ "\n"

bash

j@mes $ cat grids.txt | sort | uniq -c | sort -h | tail
  14642 west
  15424 oboe
  15516 oral
  16678 pest
  17451 test
  19541 psst
  22165 aria
  26541 oleo
  28531 area
  85689 urea

bash

j@mes $ awk -vFS="" '{for(i=1;i<=NF;i++)w[$i]++}END{for(i in w) print w[i],i}' grids.txt | sort -hr
  1673174 e
  1428194 a
  1307329 s
  781441 t
  722476 o
  709668 l
  693442 r
  450942 p
  448701 n
  424290 i
  324295 d
  296590 m
  246367 w
  236242 c
  221680 u
  204857 h
  199943 b
  185596 g
  114375 k
  106834 v
  104330 y
  80840 f
  17625 x
  4530 j
  4030 z
  33 q