General updates

[honeycomb-puzzle.git] / honeycomb-bits-unpartitioned.hs

diff --git a/honeycomb-bits-unpartitioned.hs b/honeycomb-bits-unpartitioned.hs
new file mode 100644 (file)
index 0000000..5bff91a
--- /dev/null
+++ b/honeycomb-bits-unpartitioned.hs
@@ -0,0 +1,120 @@
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!))
+import Data.List
+import Data.Word
+import Data.Bits
+-- import Data.Function
+
+type LetterSet = Word32
+type WordSet = M.Map LetterSet (S.Set String)
+type ScoredSet = M.Map LetterSet Int
+type PartitionedScoredSet = M.Map LetterSet ScoredSet
+
+data Honeycomb = Honeycomb LetterSet LetterSet
+    -- deriving (Show, Eq, Ord)
+    deriving (Eq, Ord)
+
+instance Show Honeycomb where
+    show (Honeycomb m ls) = "Honeycomb " ++ (show $ decode m) ++ " | " ++ (show $ decode ls)
+
+main = do
+    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 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 ((7 == ) . popCount) $ M.keysSet scoredSets
+    let plausibleHoneycombs = mkPlausibleHoneycombs pangramSets
+    -- this takes 6 minutes to execute
+    -- let bestHoneycomb = maximumBy (compare `on` (scoreHoneycombP partScoredSets)) 
+    --                         (S.toList plausibleHoneycombs)
+
+    -- this takes 2 minutes to execute                             
+    let bestHoneycomb = findBestHoneycomb scoredSets plausibleHoneycombs
+    print bestHoneycomb
+
+
+encode :: String -> LetterSet
+encode letters = foldl' encodeLetter zeroBits ['a' .. 'z']
+    where encodeLetter w l 
+            | l `elem` letters = setBit (shift w 1) 0
+            | otherwise = shift w 1
+
+decode :: LetterSet -> S.Set Char
+-- decode letterSet = S.filter present $ S.fromList ['a' .. 'z']
+--     where present l = (encode [l] .&. letterSet) > 0
+decode letterSet = S.fromList $ filter present ['a' .. 'z']
+    where present c = testBit letterSet $ negate (fromEnum c - fromEnum 'z')
+
+(⊂) :: LetterSet -> LetterSet -> Bool
+(⊂) this that = (this .&. that == this)
+
+mkWordSets :: [String] -> WordSet
+mkWordSets = foldr addWord M.empty
+    where addWord w = M.insertWith S.union (encode w) (S.singleton w)
+
+present :: LetterSet -> Honeycomb -> Bool
+present target (Honeycomb mandatory letters) =
+    -- (mandatory .&. target == mandatory) && (target .&. letters == target)
+    mandatory ⊂ target && target ⊂ 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
+--           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 (popCount letterSet) == 7 then (S.size scoringWords) * 7 else 0
+
+mkPartitionedScoredSets scoredSets = M.fromList [(encode [c], scoreSetWithLetter $ encode [c]) | c <- ['a'..'z']]
+    where scoreSetWithLetter c = M.filterWithKey (\k _ -> (c .&. k) == c) scoredSets
+
+
+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.⊂` letters) hasMand
+--           validScores = M.elems hasLetters
+scoreHoneycombP scoredSets (Honeycomb mandatory letters) = 
+    M.foldrWithKey scoreLetters 0 (scoredSets ! mandatory)
+    where scoreLetters ls score total
+            -- | (ls .&. letters) == ls = score + total
+            | ls ⊂ letters = score + total
+            | otherwise = total
+
+mkPlausibleHoneycombs :: S.Set LetterSet -> S.Set Honeycomb
+mkPlausibleHoneycombs pangramSets = S.foldr S.union S.empty honeycombSets
+    where honeycombSets = S.map honeycombsOfLetters pangramSets
+          honeycombsOfLetters ls = S.map (\l -> Honeycomb (encode [l]) ls) $ decode ls 
+
+
+findBestHoneycomb scoredSets honeycombs = 
+    S.foldr (betterHc scoredSets) (0, initHc) honeycombs
+    where initHc = Honeycomb (encode "a") (encode "a")
+
+betterHc scoredSets hc (bestScore, bestHc) 
+    | thisScore > bestScore = (thisScore, hc)
+    | otherwise             = (bestScore, bestHc)
+    where thisScore = scoreHoneycomb scoredSets hc