Muhkeimmat sanaparit

muhkeimmat.hs

module Main where

import Prelude hiding (mapM_)
import Data.List
import Data.Char
import Data.Foldable (mapM_)
import qualified Data.Set as S
import qualified Data.Tuple as T (swap)

characters = "abcdefghijklmnopqrstuvwxyzåäö"

type CharGroup = (S.Set Char, [String])
type ScoreGroup = (Int, [(String, String)])

main = do
	text <- readFile "alastalon_salissa.txt"
        printResults $ solve text 

printResults :: ScoreGroup -> IO ()
printResults (score, results) = do
	putStrLn $ "Muhkeimpien parien pisteet: " ++ show score
	let printPair = \pair -> case pair of (a, b) -> putStrLn (a ++ ", " ++ b)
	mapM_ printPair results

solve :: String -> ScoreGroup 
solve text = let distinctWords = distinctLowerCaseWords $ words text
                 charSetsToWords = groupWordsByCharSet distinctWords
                 lesserSubsetsFiltered = filterProperSubsets charSetsToWords
                 pairs = pairCandidates lesserSubsetsFiltered
	         greatestPairs = findGreatestPairs pairs
             in case greatestPairs of
	         (score, pairs') -> (score, toUniquePairs pairs')

toUniquePairs :: [(String, String)] -> [(String, String)]
toUniquePairs [] = []
toUniquePairs (p : ps) = if (T.swap p) `elem` ps
		         then toUniquePairs ps
		         else p : (toUniquePairs ps)

findGreatestPairs :: [(String, String)] -> ScoreGroup 
findGreatestPairs pairs = maximumBy compareScores scoresToWords where
	scoresToWords = fmap (\x -> ((fst . head) x, fmap snd x)) groupedScores
	groupedScores = groupBy scoresEqual sortedByScore
	sortedByScore = sortBy compareScores pairsWithScores
	pairsWithScores = fmap (\p -> (score p, p)) pairs
	compareScores = \a b -> compare (fst a) (fst b)
	scoresEqual = \a b -> (fst a) == (fst b)

distinctLowerCaseWords :: [String] -> [String]
distinctLowerCaseWords = S.toList . S.map cleanWord . S.fromList where
	cleanWord = removeNonAlphabet . (fmap toLower)
	removeNonAlphabet = filter (\w -> w `elem` characters)

groupWordsByCharSet :: [String] -> [CharGroup]
groupWordsByCharSet words = 
	removeEmpty $ fmap simplifyGroup groupedCharsToWords where
		removeEmpty = filter (\g -> (S.size . fst) g > 0)
		simplifyGroup = \g -> ((fst . head) g, fmap snd g)
		groupedCharsToWords = groupBy charSetsEqual sortedCharsToWords
		charSetsEqual = \a b -> (fst a) == (fst b)
		sortedCharsToWords = sortBy compareCharSets charsToWords
		compareCharSets = \a b -> compare (fst a) (fst b)
		charsToWords = fmap (\w -> (wordToCharSet w, w)) words

filterProperSubsets :: [CharGroup] -> [CharGroup]
filterProperSubsets groups = filterProperSubsets' orderedGroups where
    orderedGroups = sortDescByCharSetLength groups
    filterProperSubsets' [] = []
    filterProperSubsets' groups = headItem : filterProperSubsets' filteredTail where
        filteredTail = filter notProperSubsetOfHead (tail groups)
	notProperSubsetOfHead = 
		\x -> let this = fst x 
			  headSet = fst headItem
		      in not $ this `S.isProperSubsetOf` headSet
        headItem = head groups

sortDescByCharSetLength :: [CharGroup] -> [CharGroup]
sortDescByCharSetLength = sortBy compareGroupLength  where
    compareGroupLength = \a b -> compare (groupLength b) (groupLength a)
    groupLength = S.size . fst 

pairCandidates :: [CharGroup] -> [(String, String)]
pairCandidates groups = generatePairs $ groups >>= snd

score :: (String, String) -> Int
score (x, y) = S.size $ wordToCharSet combinedWords where
    combinedWords = fmap toLower $ x ++ y

wordToCharSet :: String -> S.Set Char
wordToCharSet word = S.fromList $ foldl' addUniqueChar [] characters where
    addUniqueChar = \unique char -> if char `elem` word
                                        then char : unique
                                        else unique

generatePairs :: Eq a => [a] -> [(a,a)]
generatePairs xs = [(x, y) | x <- xs, y <- xs]