import qualified Data.Map.Strict as M
import Data.Map.Strict ((!))
import Data.List
-import Data.Function
+-- import Data.Function
type LetterSet = S.Set Char
type WordSet = M.Map LetterSet (S.Set String)
deriving (Show, Eq, Ord)
main = do
- lines <- readFile "enable1.txt"
- let allWords = [w | w <- words lines,
+ allWords <- readFile "enable1.txt"
+ let validWords = [w | w <- words allWords,
length w >= 4,
(S.size $ S.fromList w) <= 7,
's' `notElem` w]
- let wordSets = mkWordSets allWords
- let scoredSets = M.mapWithKey (\ls _ -> scoreLetterSet wordSets ls) wordSets
+ let wordSets = mkWordSets validWords
+ -- let scoredSets = M.mapWithKey (\ls _ -> scoreLetterSet wordSets ls) wordSets
+ let scoredSets = M.mapWithKey scoreLetterSet wordSets
let partScoredSets = mkPartitionedScoredSets scoredSets
- let pangramSets = S.filter (\k -> (S.size k == 7) && (not ('s' `S.member` k))) $ M.keysSet scoredSets
+ -- let pangramSets = S.filter (\k -> (S.size k == 7) && (not ('s' `S.member` k))) $ M.keysSet scoredSets
+ let pangramSets = S.filter ((7 == ) . S.size) $ M.keysSet scoredSets
let plausibleHoneycombs = mkPlausibleHoneycombs pangramSets
-- this takes 6 minutes to execute
-- let bestHoneycomb = maximumBy (compare `on` (scoreHoneycombP partScoredSets))
mkWordSets :: [String] -> WordSet
-mkWordSets ws = foldr addWord M.empty ws
+mkWordSets = foldr addWord M.empty
where addWord w = M.insertWith S.union (S.fromList w) (S.singleton w)
present :: LetterSet -> Honeycomb -> Bool
present target (Honeycomb mandatory letters) =
(mandatory `S.member` target) && (target `S.isSubsetOf` letters)
-scoreLetterSet :: WordSet -> LetterSet -> Int
-scoreLetterSet wordSets letterSet = bonus + (sum $ fmap scoreAWord (S.toList scoringWords))
- where scoringWords = wordSets ! letterSet
- scoreAWord w = if length w == 4 then 1 else length w
+-- scoreLetterSet :: WordSet -> LetterSet -> Int
+-- scoreLetterSet wordSets letterSet = bonus + (sum $ fmap scoreAWord (S.toList scoringWords))
+-- where scoringWords = wordSets ! letterSet
+-- scoreAWord w = if length w == 4 then 1 else length w
+-- bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
+scoreLetterSet :: LetterSet -> S.Set String -> Int
+-- scoreLetterSet letterSet scoringWords = bonus + (sum $ fmap scoreAWord (S.toAscList scoringWords))
+scoreLetterSet letterSet scoringWords = bonus + (S.foldr' (\w t -> t + scoreAWord w) 0 scoringWords)
+ where scoreAWord w
+ | length w == 4 = 1
+ | otherwise = length w
bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
mkPartitionedScoredSets scoredSets = M.fromList [(c, scoreSetWithLetter c) | c <- ['a'..'z']]
where scoreSetWithLetter c = M.filterWithKey (\k _ -> c `S.member` k) scoredSets
-scoreHoneycomb :: ScoredSet -> Honeycomb -> Int
-scoreHoneycomb scoredSets (Honeycomb mandatory letters) = sum(validScores)
- where hasMand = M.filterWithKey (\k _ -> mandatory `S.member` k) scoredSets
- hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
- validScores = M.elems hasLetters
+
+scoreHoneycombSeparate, scoreHoneycomb :: ScoredSet -> Honeycomb -> Int
+scoreHoneycombSeparate scoredSets honeycomb = sum(validScores)
+ where inHoneycomb = M.filterWithKey (\k _ -> present k honeycomb) scoredSets
+ validScores = M.elems inHoneycomb
+scoreHoneycomb scoredSets honeycomb = M.foldrWithKey scoreLetters 0 scoredSets
+ where scoreLetters letters score total
+ | present letters honeycomb = score + total
+ | otherwise = total
+
+
scoreHoneycombP :: PartitionedScoredSet -> Honeycomb -> Int
-scoreHoneycombP scoredSets (Honeycomb mandatory letters) = sum(validScores)
- where hasMand = scoredSets ! mandatory
- hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
- validScores = M.elems hasLetters
+-- scoreHoneycombP scoredSets (Honeycomb mandatory letters) = sum validScores
+-- where hasMand = scoredSets ! mandatory
+-- hasLetters = M.filterWithKey (\k _ -> k `S.isSubsetOf` letters) hasMand
+-- validScores = M.elems hasLetters
+scoreHoneycombP scoredSets (Honeycomb mandatory letters) =
+ M.foldrWithKey scoreLetters 0 (scoredSets ! mandatory)
+ where scoreLetters ls score total
+ | ls `S.isSubsetOf` letters = score + total
+ | otherwise = total
mkPlausibleHoneycombs :: S.Set LetterSet -> S.Set Honeycomb
mkPlausibleHoneycombs pangramSets = S.foldr S.union S.empty honeycombSets
S.foldr (betterHc partScoredSets) (0, initHc) honeycombs
where initHc = Honeycomb 'a' $ S.singleton 'a'
-betterHc partScoredSets hc (bestScore, bestHc) =
- if thisScore > bestScore
- then (thisScore, hc)
- else (bestScore, bestHc)
+betterHc partScoredSets hc (bestScore, bestHc)
+ | thisScore > bestScore = (thisScore, hc)
+ | otherwise = (bestScore, bestHc)
where thisScore = scoreHoneycombP partScoredSets hc