blob: 67a03246e61fbea1f2b104a6d544b10fac3da14a (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
{-# LANGUAGE ExistentialQuantification, RankNTypes, GADTs #-}
module Greedy (greedyAI) where
import Wordle
import Text.Printf
import Data.List (nub, maximumBy)
import Data.Ord (comparing)
import Data.Set (Set)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import qualified Data.Map as Map
newtype GreedyState = GreedyState [String]
greedyAI :: Environment -> AI
greedyAI env = AI
(GreedyState (Set.toList $ wordList env))
greedyGuess
greedyUpdate
greedyUpdate :: GreedyState -> Hints -> IO GreedyState
greedyUpdate (GreedyState possibleWords) (Hints hints) = do
let state' = filter matchesHints possibleWords
return $ GreedyState state'
-- Filters out all the words it can't possibly be base on the hints returned.
where matchesHints word =
flip all (zip hints word) $ \((c, h), w) -> do
case h of
-- The secret word contains the character c, but not in this
-- position.
Contains -> c `elem` word && c /= w
-- The secret word contains the character c in this position.
Correct -> w == c
-- The secret word does not contain this character.
DoesNotContain -> c `notElem` word
greedyGuess :: GreedyState -> Environment -> IO String
greedyGuess (GreedyState possibleWords) env =
case possibleWords of
-- Only one thing left to guess. Go ahead and guess it.
[guess] -> return guess
-- Return the highest ranked word in the wordList. If there are no words
-- that give any more information (i.e. all possible words left are anagrams
-- of each other), then return an arbitrary word in the possibleWords list.
(h:_) ->
let ans = maximumBy (comparing rankWord) (Set.toList $ wordList env) in
if rankWord ans == 0
then return h -- Pick an arbitrary one
else return ans
-- No words left to guess? This is theoretically not possible.
[] -> do
putStrLn "Impossible!!!"
return ""
where
-- Map of letters to their rankings. Used as a cache.
letterRanks = Map.fromList $ map (\l -> (l, rankLetter l)) ['a'..'z']
-- This attempts to rank a word based on how much information that word can
-- offer to the guessing engine. Namely the power of that word to eliminate
-- possible words from the possibleWords list.
--
-- This is just the sum of the individual rankings for each letter in the
-- word.
rankWord =
sum .
map (\l -> fromMaybe 0 (Map.lookup l letterRanks)) .
nub
-- A letter's rank is based on how much "elimination power." A letter where
-- exactly half the words contain it and the other half do not is said to
-- have the highest elimination power because it is guaranteed that it will
-- narrow down the options by at least half.
rankLetter l =
let numApplied =
sum $ map
(\word -> if l `elem` word then 1 else 0)
possibleWords
x = fromIntegral numApplied / fromIntegral (length possibleWords) in
1 - (x * 2 - 1) ** 2
|
