Rakkauden fast track in Haskell

haskell-love.hs

module Main where

import Data.Char (toLower)
import Data.Tuple (swap)
import Data.List (foldl')
import qualified Data.Set as Set
import Control.Monad (guard)
import System.IO

type Pair = (String, String)

main = do
  let sourceFile = "fast_track_generoitu_nimilista.txt"
  withFile sourceFile ReadMode (\handle -> do 
    contents <- hGetContents handle
    let numberOfCompatiblePairs = solve $ lines contents
    putStrLn $ "Compatible pairs: " ++ show numberOfCompatiblePairs
    )

solve :: [String] -> Int
solve people = 
  let pairs = formPairs people
      compatibilities = map calculatePairCompatibility pairs
  in length $ filter (\num -> num >= 99) compatibilities

formPairs :: [String] -> [Pair]
formPairs people = 
  let peopleCombinations = allPairCombinations people
      distinctPairs = foldl' insertIfNotPresentSwapped Set.empty peopleCombinations
  in Set.toList distinctPairs

insertIfNotPresentSwapped :: Set.Set Pair -> Pair -> Set.Set Pair
insertIfNotPresentSwapped pairs pair = 
  if (Set.member (swap pair) pairs) 
  then pairs 
  else Set.insert pair pairs
  
allPairCombinations :: [String] -> [Pair]
allPairCombinations people = do
  person1 <- people
  person2 <- people
  guard (person1 /= person2)
  return (person1, person2) 

calculatePairCompatibility :: Pair -> Int
calculatePairCompatibility (one, other) = 
  let numbers = zipWith (+) (charsInPairs one) (charsInPairs other)
  in head $ sumResult numbers

sumResult :: [Int] -> [Int]
sumResult [one, other] = [one * 10 + other]
sumResult numbers =
  let numberPairs = zip numbers $ tail numbers
      summedNumbers = map (fixNumsGteq10 . sumTuple) numberPairs
  in sumResult summedNumbers
      
sumTuple :: (Num a) => (a, a) -> a
sumTuple (a, b) = a + b

fixNumsGteq10 :: Int -> Int
fixNumsGteq10 number
  | number >= 10 = floor (fromIntegral number / 10) + number `mod` 10
  | otherwise    = number
  
charsInPairs :: String -> [Int]
charsInPairs str = fmap (timesStringContainsChar "pairs" . toLower) str

timesStringContainsChar :: String -> Char -> Int
timesStringContainsChar str letter = 
  foldl (\number item -> if (item == letter) then number + 1 else number) 0 str