X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=honeycomb.hs;fp=honeycomb.hs;h=404fc57f7c763b6b6a400e89246e23952d777e02;hb=978aa4af1b4a8753d0cd04f7fcceaf6d899bca79;hp=84b6f0ed3c0a0154d612723b0551be1a2df43c5c;hpb=68b4df6b83ce0f6bea2379d3f46d7296dd36a3c9;p=honeycomb-puzzle.git

diff --git a/honeycomb.hs b/honeycomb.hs
index 84b6f0e..404fc57 100644
--- a/honeycomb.hs
+++ b/honeycomb.hs
@@ -2,7 +2,7 @@ import qualified Data.Set as S
 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)
@@ -13,15 +13,17 @@ data Honeycomb = Honeycomb Char LetterSet
     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)) 
@@ -33,33 +35,51 @@ main = do
 
 
 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
@@ -71,8 +91,7 @@ findBestHoneycomb partScoredSets honeycombs =
     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