honeycomb-bits-unpartitioned.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.Word
   6 import Data.Bits
   7 -- import Data.Function
   8
   9 type LetterSet = Word32
  10 type WordSet = M.Map LetterSet (S.Set String)
  11 type ScoredSet = M.Map LetterSet Int
  12 type PartitionedScoredSet = M.Map LetterSet ScoredSet
  13
  14 data Honeycomb = Honeycomb LetterSet LetterSet
  15     -- deriving (Show, Eq, Ord)
  16     deriving (Eq, Ord)
  17
  18 instance Show Honeycomb where
  19     show (Honeycomb m ls) = "Honeycomb " ++ (show $ decode m) ++ " | " ++ (show $ decode ls)
  20
  21 main = do
  22     allWords <- readFile "enable1.txt"
  23     let validWords = [w | w <- words allWords,
  24                         length w >= 4,
  25                         (S.size $ S.fromList w) <= 7,
  26                         's' `notElem` w]
  27     let wordSets = mkWordSets validWords
  28     -- let scoredSets = M.mapWithKey (\ls _ -> scoreLetterSet wordSets ls) wordSets
  29     let scoredSets = M.mapWithKey scoreLetterSet wordSets
  30     let partScoredSets = mkPartitionedScoredSets scoredSets
  31     -- let pangramSets = S.filter (\k -> (S.size k == 7) && (not ('s' `S.member` k))) $ M.keysSet scoredSets
  32     let pangramSets = S.filter ((7 == ) . popCount) $ M.keysSet scoredSets
  33     let plausibleHoneycombs = mkPlausibleHoneycombs pangramSets
  34     -- this takes 6 minutes to execute
  35     -- let bestHoneycomb = maximumBy (compare `on` (scoreHoneycombP partScoredSets))
  36     --                         (S.toList plausibleHoneycombs)
  37
  38     -- this takes 2 minutes to execute
  39     let bestHoneycomb = findBestHoneycomb scoredSets plausibleHoneycombs
  40     print bestHoneycomb
  41
  42
  43 encode :: String -> LetterSet
  44 encode letters = foldl' encodeLetter zeroBits ['a' .. 'z']
  45     where encodeLetter w l
  46             | l `elem` letters = setBit (shift w 1) 0
  47             | otherwise = shift w 1
  48
  49 decode :: LetterSet -> S.Set Char
  50 -- decode letterSet = S.filter present $ S.fromList ['a' .. 'z']
  51 --     where present l = (encode [l] .&. letterSet) > 0
  52 decode letterSet = S.fromList $ filter present ['a' .. 'z']
  53     where present c = testBit letterSet $ negate (fromEnum c - fromEnum 'z')
  54
  55 (⊂) :: LetterSet -> LetterSet -> Bool
  56 (⊂) this that = (this .&. that == this)
  57
  58 mkWordSets :: [String] -> WordSet
  59 mkWordSets = foldr addWord M.empty
  60     where addWord w = M.insertWith S.union (encode w) (S.singleton w)
  61
  62 present :: LetterSet -> Honeycomb -> Bool
  63 present target (Honeycomb mandatory letters) =
  64     -- (mandatory .&. target == mandatory) && (target .&. letters == target)
  65     mandatory ⊂ target && target ⊂ letters
  66
  67 -- scoreLetterSet :: WordSet -> LetterSet -> Int
  68 -- scoreLetterSet wordSets letterSet = bonus + (sum $ fmap scoreAWord (S.toList scoringWords))
  69 --     where scoringWords = wordSets ! letterSet
  70 --           scoreAWord w = if length w == 4 then 1 else length w
  71 --           bonus = if (S.size letterSet) == 7 then (S.size scoringWords) * 7 else 0
  72 scoreLetterSet :: LetterSet -> S.Set String -> Int
  73 -- scoreLetterSet letterSet scoringWords = bonus + (sum $ fmap scoreAWord (S.toAscList scoringWords))
  74 scoreLetterSet letterSet scoringWords = bonus + (S.foldr' (\w t -> t + scoreAWord w) 0 scoringWords)
  75     where scoreAWord w
  76             | length w == 4 = 1
  77             | otherwise     = length w
  78           bonus = if (popCount letterSet) == 7 then (S.size scoringWords) * 7 else 0
  79
  80 mkPartitionedScoredSets scoredSets = M.fromList [(encode [c], scoreSetWithLetter $ encode [c]) | c <- ['a'..'z']]
  81     where scoreSetWithLetter c = M.filterWithKey (\k _ -> (c .&. k) == c) scoredSets
  82
  83
  84 scoreHoneycombSeparate, scoreHoneycomb :: ScoredSet -> Honeycomb -> Int
  85 scoreHoneycombSeparate scoredSets honeycomb = sum(validScores)
  86     where inHoneycomb = M.filterWithKey (\k _ -> present k honeycomb) scoredSets
  87           validScores = M.elems inHoneycomb
  88 scoreHoneycomb scoredSets honeycomb = M.foldrWithKey scoreLetters 0 scoredSets
  89     where scoreLetters letters score total
  90             | present letters honeycomb = score + total
  91             | otherwise = total
  92
  93
  94
  95 scoreHoneycombP :: PartitionedScoredSet -> Honeycomb -> Int
  96 -- scoreHoneycombP scoredSets (Honeycomb mandatory letters) = sum validScores
  97 --     where hasMand = scoredSets ! mandatory
  98 --           hasLetters = M.filterWithKey (\k _ -> k `S.⊂` letters) hasMand
  99 --           validScores = M.elems hasLetters
 100 scoreHoneycombP scoredSets (Honeycomb mandatory letters) =
 101     M.foldrWithKey scoreLetters 0 (scoredSets ! mandatory)
 102     where scoreLetters ls score total
 103             -- | (ls .&. letters) == ls = score + total
 104             | ls ⊂ letters = score + total
 105             | otherwise = total
 106
 107 mkPlausibleHoneycombs :: S.Set LetterSet -> S.Set Honeycomb
 108 mkPlausibleHoneycombs pangramSets = S.foldr S.union S.empty honeycombSets
 109     where honeycombSets = S.map honeycombsOfLetters pangramSets
 110           honeycombsOfLetters ls = S.map (\l -> Honeycomb (encode [l]) ls) $ decode ls
 111
 112
 113 findBestHoneycomb scoredSets honeycombs =
 114     S.foldr (betterHc scoredSets) (0, initHc) honeycombs
 115     where initHc = Honeycomb (encode "a") (encode "a")
 116
 117 betterHc scoredSets hc (bestScore, bestHc)
 118     | thisScore > bestScore = (thisScore, hc)
 119     | otherwise             = (bestScore, bestHc)
 120     where thisScore = scoreHoneycomb scoredSets hc