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     lines <- readFile "enable1.txt"
  17     let allWords = [w | w <- words lines,
  18                         length w >= 4,
  19                         (S.size $ S.fromList w) <= 7,
  20                         's' `notElem` w]
  21     let wordSets = mkWordSets allWords
  22     let scoredSets = M.mapWithKey (\ls _ -> scoreLetterSet wordSets ls) wordSets
  23     let partScoredSets = mkPartitionedScoredSets scoredSets
  24     let pangramSets = S.filter (\k -> (S.size k == 7) && (not ('s' `S.member` k))) $ M.keysSet scoredSets
  25     let plausibleHoneycombs = mkPlausibleHoneycombs pangramSets
  26     -- this takes 6 minutes to execute
  27     -- let bestHoneycomb = maximumBy (compare `on` (scoreHoneycombP partScoredSets))
  28     --                         (S.toList plausibleHoneycombs)
  29
  30     -- this takes 2 minutes to execute
  31     let bestHoneycomb = findBestHoneycomb partScoredSets plausibleHoneycombs
  32     print bestHoneycomb
  33
  34
  35 mkWordSets :: [String] -> WordSet
  36 mkWordSets ws = foldr addWord M.empty ws
  37     where addWord w = M.insertWith S.union (S.fromList w) (S.singleton w)
  38
  39 present :: LetterSet -> Honeycomb -> Bool
  40 present target (Honeycomb mandatory letters) =
  41     (mandatory `S.member` target) && (target `S.isSubsetOf` letters)
  42
  43 scoreLetterSet :: WordSet -> LetterSet -> Int
  44 scoreLetterSet wordSets letterSet = bonus + (sum $ fmap scoreAWord (S.toList scoringWords))
  45     where scoringWords = wordSets ! letterSet
  46           scoreAWord w = if length w == 4 then 1 else length w
  47           bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
  48
  49 mkPartitionedScoredSets scoredSets = M.fromList [(c, scoreSetWithLetter c) | c <- ['a'..'z']]
  50     where scoreSetWithLetter c = M.filterWithKey (\k _ -> c `S.member` k) scoredSets
  51
  52 scoreHoneycomb :: ScoredSet -> Honeycomb -> Int
  53 scoreHoneycomb scoredSets (Honeycomb mandatory letters) = sum(validScores)
  54     where hasMand = M.filterWithKey (\k _ -> mandatory `S.member` k) scoredSets
  55           hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
  56           validScores = M.elems hasLetters
  57
  58 scoreHoneycombP :: PartitionedScoredSet -> Honeycomb -> Int
  59 scoreHoneycombP scoredSets (Honeycomb mandatory letters) = sum(validScores)
  60     where hasMand = scoredSets ! mandatory
  61           hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
  62           validScores = M.elems hasLetters
  63
  64 mkPlausibleHoneycombs :: S.Set LetterSet -> S.Set Honeycomb
  65 mkPlausibleHoneycombs pangramSets = S.foldr S.union S.empty honeycombSets
  66     where honeycombSets = S.map honeycombsOfLetters pangramSets
  67           honeycombsOfLetters ls = S.map (\l -> Honeycomb l ls) ls
  68
  69
  70 findBestHoneycomb partScoredSets honeycombs =
  71     S.foldr (betterHc partScoredSets) (0, initHc) honeycombs
  72     where initHc = Honeycomb 'a' $ S.singleton 'a'
  73
  74 betterHc partScoredSets hc (bestScore, bestHc) =
  75     if thisScore > bestScore
  76     then (thisScore, hc)
  77     else (bestScore, bestHc)
  78     where thisScore = scoreHoneycombP partScoredSets hc