honeycomb-unordered.hs

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