Skip to content

Instantly share code, notes, and snippets.

@ambuc

ambuc/crossword.hs

Last active May 28, 2017 05:28
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save ambuc/ac4ed787e1b9bb3eba08bb02c9b25c49 to your computer and use it in GitHub Desktop.
Save ambuc/ac4ed787e1b9bb3eba08bb02c9b25c49 to your computer and use it in GitHub Desktop.
Download ZIP
Puzzle Pong - Generating All Possible 4x4 Crosswords
Raw
crossword.hs
import qualified Control.Monad as N (forM)
import qualified Data.Maybe as B (isJust, isNothing, fromJust, 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)
type Box = Maybe Char
type Grid = [Box]
data Idx a = Row a | Col a deriving (Eq, Ord, Show)
type Paths = M.Map String [Char]
n = 4
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)
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
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
gridWrite :: String -> [(Idx Int, Idx Int)] -> Grid -> Grid
gridWrite cs ls g = foldr (uncurry gridSet) g $ zip cs ls
allWords :: [String]
allWords = filter (\x -> length x == n) $ filter (L.all C.isAsciiLower) W.allStringWords
dictMake :: Int -> Paths
dictMake len = foldr (\xs -> M.insert (key xs) (val xs)) M.empty nglyphs
where key = take len . head
val = L.nub . map (head . drop len)
nglyphs = L.groupBy ((==) `F.on` take len) $ map (take $ len+1) allWords
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 :: 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
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
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]
main = print $ length $ grids
Raw
crossword.prof
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
individual inherited
COST CENTRE MODULE no. entries %time %alloc %time %alloc
MAIN MAIN 87 0 0.0 0.0 100.0 100.0
allStringWords Language.Words 220 0 0.0 0.0 0.0 0.0
main Main 175 0 0.0 0.0 0.0 0.0
CAF Main 173 0 0.0 0.0 99.9 99.9
n Main 185 1 0.0 0.0 0.0 0.0
allWords Main 178 1 0.0 0.0 0.0 0.0
allWords.\ Main 184 64024 0.0 0.0 0.0 0.0
seeds Main 177 1 0.2 0.0 0.6 0.3
seeds.blank Main 191 1 0.0 0.0 0.0 0.0
seeds.firstCol Main 190 1 0.0 0.0 0.0 0.0
seeds.firstRow Main 187 1 0.0 0.0 0.0 0.0
gridWrite Main 186 305532 0.1 0.0 0.3 0.3
gridSet Main 188 1222128 0.2 0.3 0.2 0.3
gridSet.i Main 189 1222128 0.0 0.0 0.0 0.0
grids Main 176 1 5.7 2.6 99.4 99.5
grids.noRepeats Main 214 1094370 0.1 0.0 3.5 3.7
grids.wordsIn Main 215 1094370 1.9 1.2 3.4 3.7
gridGet Main 217 8754960 0.8 0.9 1.5 2.5
chunksOf Data.List.Split.Internals 218 4377480 0.4 1.0 0.8 1.6
build Data.List.Split.Internals 219 4377480 0.3 0.5 0.3 0.5
grids.wordsIn.\ Main 216 4 0.0 0.0 0.0 0.0
grids.paths Main 202 1 0.0 0.0 0.0 0.0
dictMake Main 203 3 0.0 0.0 0.0 0.0
dictMake.key Main 208 3 0.0 0.0 0.0 0.0
dictMake.val Main 206 3 0.0 0.0 0.0 0.0
dictMake.\ Main 205 1550 0.0 0.0 0.0 0.0
dictMake.key Main 209 0 0.0 0.0 0.0 0.0
dictMake.val Main 207 0 0.0 0.0 0.0 0.0
dictMake.nglyphs Main 204 3 0.0 0.0 0.0 0.0
children Main 192 39353249 10.0 6.1 90.1 93.2
gridSet Main 212 40294853 9.2 20.5 9.2 20.5
gridSet.i Main 213 40294853 0.0 0.0 0.0 0.0
children.r Main 211 39335803 0.2 0.0 0.2 0.0
children.indices Main 198 1 0.0 0.0 0.0 0.0
children.(...) Main 197 39353249 13.1 14.1 13.1 14.1
children.c Main 196 39353249 0.3 0.0 0.3 0.0
children.poss Main 193 39353249 1.4 1.4 57.3 52.5
intersect Main 210 269774420 5.3 1.8 5.3 1.8
children.poss.setValid Main 194 39353249 5.5 6.3 50.6 49.2
children.nextIn Main 201 78689052 20.8 0.0 20.8 0.0
gridGet Main 195 78689052 10.3 15.9 24.3 43.0
chunksOf Data.List.Split.Internals 199 39353249 6.7 17.8 14.0 27.1
build Data.List.Split.Internals 200 39353249 7.3 9.3 7.3 9.3
main Main 174 1 0.0 0.0 0.0 0.0
CAF Language.Words 172 0 0.0 0.0 0.1 0.1
getDataFileName Paths_words 180 1 0.0 0.0 0.0 0.0
allStringWords Language.Words 179 1 0.1 0.1 0.1 0.1
getDataFileName Paths_words 181 0 0.0 0.0 0.0 0.0
getDataDir Paths_words 183 0 0.0 0.0 0.0 0.0
CAF Paths_words 171 0 0.0 0.0 0.0 0.0
getDataDir Paths_words 182 1 0.0 0.0 0.0 0.0
CAF GHC.IO.Encoding 138 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Exception 137 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Handle.FD 135 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Handle.Internals 134 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Handle.Text 128 0 0.0 0.0 0.0 0.0
CAF GHC.Conc.Signal 120 0 0.0 0.0 0.0 0.0
CAF GHC.IO.Encoding.Iconv 112 0 0.0 0.0 0.0 0.0
CAF GHC.IO.FD 111 0 0.0 0.0 0.0 0.0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment