import Control.Applicative ((<$>)) import Data.List.Utils (split) removeEmpty = filter (not . null) homophones <- removeEmpty . map words . lines <$> readFile "homophones.list" import Control.Monad (forM_) import Data.List (intercalate) -- Show ten of the homophone sets forM_ (take 10 homophones) $ \ homs -> putStrLn $ intercalate "\t" homs data WordPair = WordPair String String -- Convert a list of homophones into a list of word pairs. -- Note that the wordpairs should only use the first of the -- list as the first word, since there will be repeat sets. -- For instance, the set ["a", "b", "c"] would only generate -- word pairs [WordPair "a" "b", WordPair "a" "c"]. pairs :: [String] -> [WordPair] pairs (str:strs) = map (WordPair str) strs -- All pairs of words we consider homophones. wordPairs = concatMap pairs homophones data History = Reduce String String | Substitute Char data Relation = Relation [History] String String toRelation :: WordPair -> Relation toRelation (WordPair first second) = Relation [] first second initRelations = map toRelation wordPairs reduce :: Relation -> Relation reduce rel@(Relation hist first second) | canReduce first second = go (first, second) -- Note that we also have to be careful with the history. -- If the `reduce` does nothing, then we do not want to add -- anything to the history of the relation. | otherwise = rel where -- A reduction can happen if both strings are non-zero -- and share a common first or last letter. canReduce first second = not (null first) && not (null second) && (head first == head second || last first == last second) -- Modified history including this reduction. hist' = Reduce first second : hist -- Base case: if we've reduced a word pair to an empty string -- and something else, we're done, as that something else -- is equivalent to the identity element. go ("", word) = Relation hist' word "" go (word, "") = Relation hist' word "" go (first, second) -- Chop off the first element if they're equal. | head first == head second = go (tail first, tail second) -- Chop off the last element if they're equal. | last first == last second = go (init first, init second) -- If netiher first nor last element are equal, -- we've simplified the relation down as much -- as we can simplify it. | otherwise = Relation hist' first second import Data.List.Utils (replace) -- Generate a new relation by removing characters we know to be -- the identity. Make sure to update the history of the relation -- with this substitution! substitute :: Char -> Relation -> Relation substitute char rel@(Relation hist first second) | canSubstitute first second = Relation (Substitute char : hist) (replaced first) (replaced second) | otherwise = rel where canSubstitute first second = char `elem` first || char `elem` second replaced = replace [char] "" data FoundIdent = FoundIdent { char :: Char, hist :: [History] } -- mapMaybe = map fromJust . filter isJust . map import Data.Maybe (mapMaybe) identities :: [Relation] -> [FoundIdent] identities = mapMaybe go where go :: Relation -> Maybe FoundIdent go (Relation hist [char] "") = Just $ FoundIdent char hist go (Relation hist "" [char]) = Just $ FoundIdent char hist go _ = Nothing import Data.List (nubBy) import Data.Function (on) -- The iteration starts with a list of known identity elements -- and the current set of relations. It outputs the updated -- relations and all known identity elements. iteration :: ([FoundIdent], [Relation]) -> ([FoundIdent], [Relation]) iteration (idents, relations) = (newIdents, newRelations) where -- Collect all the substitutions into a single function. substitutions = foldl (.) id $ map (substitute . char) idents -- Do all substitutions, then reduce (for each relation). newRelations = map (reduce . substitutions) relations -- We have to remove duplicate identity elements, because -- in each iteration we find multiple ways to prove that some -- letters are the identity element. We just want one. removeDuplicateIdents = nubBy ((==) `on` char) -- Find all identities in the new relations. newIdents = removeDuplicateIdents $ idents ++ identities newRelations -- Generate the infinite list of iterations and their results. initIdents = [] iterations = iterate iteration (initIdents, initRelations) -- Define a completion condition. -- We're done when there are 26 known identity elements. done (idents, _) = length idents == 26 -- Discard all iteration results until completion. -- Take the next one - the first one where the condition is met. result = head $ dropWhile (not . done) iterations import Data.List (sort) idents = fst result identChars = map char idents putStrLn $ sort identChars print $ length identChars import Text.Printf (printf) forM_ idents $ \(FoundIdent char hist) -> do printf "Proving %c = 1:\n" char forM_ (reverse hist) $ \op -> putStrLn $ case op of Reduce first second -> printf "Reduce %s and %s" first second Substitute ch -> printf "Substitute %c for ''" ch putStr "\n"