honeycomb.hs

   1 import qualified Data.Set as S
   2 import qualified Data.Map.Strict as M
   3 import Data.Map.Strict ((!))
   4 import Data.List
   5 -- import Data.Function
   6
   7 type LetterSet = S.Set Char
   8 type WordSet = M.Map LetterSet (S.Set String)
   9 type ScoredSet = M.Map LetterSet Int
  10 type PartitionedScoredSet = M.Map Char ScoredSet
  11
  12 data Honeycomb = Honeycomb Char LetterSet
  13     deriving (Show, Eq, Ord)
  14
  15 main = do
  16     allWords <- readFile "enable1.txt"
  17     let validWords = [w | w <- words allWords,
  18                         length w >= 4,
  19                         (S.size $ S.fromList w) <= 7,
  20                         's' `notElem` w]
  21     let wordSets = mkWordSets validWords
  22     -- let scoredSets = M.mapWithKey (\ls _ -> scoreLetterSet wordSets ls) wordSets
  23     let scoredSets = M.mapWithKey scoreLetterSet wordSets
  24     let partScoredSets = mkPartitionedScoredSets scoredSets
  25     -- let pangramSets = S.filter (\k -> (S.size k == 7) && (not ('s' `S.member` k))) $ M.keysSet scoredSets
  26     let pangramSets = S.filter ((7 == ) . S.size) $ M.keysSet scoredSets
  27     let plausibleHoneycombs = mkPlausibleHoneycombs pangramSets
  28     -- this takes 6 minutes to execute
  29     -- let bestHoneycomb = maximumBy (compare `on` (scoreHoneycombP partScoredSets))
  30     --                         (S.toList plausibleHoneycombs)
  31
  32     -- this takes 2 minutes to execute
  33     let bestHoneycomb = findBestHoneycomb partScoredSets plausibleHoneycombs
  34     print bestHoneycomb
  35
  36
  37 mkWordSets :: [String] -> WordSet
  38 mkWordSets = foldr addWord M.empty
  39     where addWord w = M.insertWith S.union (S.fromList w) (S.singleton w)
  40
  41 present :: LetterSet -> Honeycomb -> Bool
  42 present target (Honeycomb mandatory letters) =
  43     (mandatory `S.member` target) && (target `S.isSubsetOf` letters)
  44
  45 -- scoreLetterSet :: WordSet -> LetterSet -> Int
  46 -- scoreLetterSet wordSets letterSet = bonus + (sum $ fmap scoreAWord (S.toList scoringWords))
  47 --     where scoringWords = wordSets ! letterSet
  48 --           scoreAWord w = if length w == 4 then 1 else length w
  49 --           bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
  50 scoreLetterSet :: LetterSet -> S.Set String -> Int
  51 -- scoreLetterSet letterSet scoringWords = bonus + (sum $ fmap scoreAWord (S.toAscList scoringWords))
  52 scoreLetterSet letterSet scoringWords = bonus + (S.foldr' (\w t -> t + scoreAWord w) 0 scoringWords)
  53     where scoreAWord w
  54             | length w == 4 = 1
  55             | otherwise     = length w
  56           bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
  57
  58 mkPartitionedScoredSets scoredSets = M.fromList [(c, scoreSetWithLetter c) | c <- ['a'..'z']]
  59     where scoreSetWithLetter c = M.filterWithKey (\k _ -> c `S.member` k) scoredSets
  60
  61
  62 scoreHoneycombSeparate, scoreHoneycomb :: ScoredSet -> Honeycomb -> Int
  63 scoreHoneycombSeparate scoredSets honeycomb = sum(validScores)
  64     where inHoneycomb = M.filterWithKey (\k _ -> present k honeycomb) scoredSets
  65           validScores = M.elems inHoneycomb
  66 scoreHoneycomb scoredSets honeycomb = M.foldrWithKey scoreLetters 0 scoredSets
  67     where scoreLetters letters score total
  68             | present letters honeycomb = score + total
  69             | otherwise = total
  70
  71
  72
  73 scoreHoneycombP :: PartitionedScoredSet -> Honeycomb -> Int
  74 -- scoreHoneycombP scoredSets (Honeycomb mandatory letters) = sum validScores
  75 --     where hasMand = scoredSets ! mandatory
  76 --           hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
  77 --           validScores = M.elems hasLetters
  78 scoreHoneycombP scoredSets (Honeycomb mandatory letters) =
  79     M.foldrWithKey scoreLetters 0 (scoredSets ! mandatory)
  80     where scoreLetters ls score total
  81             | ls `S.isSubsetOf` letters = score + total
  82             | otherwise = total
  83
  84 mkPlausibleHoneycombs :: S.Set LetterSet -> S.Set Honeycomb
  85 mkPlausibleHoneycombs pangramSets = S.foldr S.union S.empty honeycombSets
  86     where honeycombSets = S.map honeycombsOfLetters pangramSets
  87           honeycombsOfLetters ls = S.map (\l -> Honeycomb l ls) ls
  88
  89
  90 findBestHoneycomb partScoredSets honeycombs =
  91     S.foldr (betterHc partScoredSets) (0, initHc) honeycombs
  92     where initHc = Honeycomb 'a' $ S.singleton 'a'
  93
  94 betterHc partScoredSets hc (bestScore, bestHc)
  95     | thisScore > bestScore = (thisScore, hc)
  96     | otherwise             = (bestScore, bestHc)
  97     where thisScore = scoreHoneycombP partScoredSets hc