quiz.hs

module Main where

import Data.List (subsequences)

data Subject 
  = ACTReading
  | ACTWriting
  | ACTEssay
  | ACTScience
  | ACTMath
  | USHistory
  | APChemistry
  deriving (Eq,Ord,Read,Show)

data Tutor = 
  Tutor 
    { tName     :: String
    , tSubjects :: [Subject]
    }
  deriving (Eq,Ord,Read,Show)

data Student = 
  Student 
    { sName     :: String
    , sSubjects :: [Subject]
    }
  deriving (Eq,Ord,Read,Show)

tutors :: [Tutor]
tutors =
  [ (Tutor "Joakim"  [ACTReading, ACTEssay, ACTWriting])
  , (Tutor "Bob"     [APChemistry,ACTScience])
  , (Tutor "Frieda"  [ACTEssay, ACTWriting])
  , (Tutor "Kseniya" [USHistory])
  , (Tutor "Maggie"  [ACTScience])
  , (Tutor "Jamal"   [ACTMath])
  ]

students :: [Student]
students =
  [ (Student "Annie"     [ACTMath])
  , (Student "Oskar"     [APChemistry])
  , (Student "Olle"      [ACTReading, ACTWriting, ACTEssay, ACTScience, ACTMath])
  , (Student "Ingrid"    [USHistory, APChemistry])
  , (Student "Yuchen"    [ACTMath])
  , (Student "Arjun"     [ACTReading, ACTWriting, ACTEssay])
  , (Student "Esmeralda" [APChemistry])
  ]

-- | number of elements in common between lists, does not account for duplicates
commonElements :: (Eq a) => [a] -> [a] -> Int
commonElements as bs = length [a | a <- as, b <- bs, a == b]

-- | True if two lists have at least one common element
hasCommonElement :: (Eq a) => [a] -> [a] -> Bool
hasCommonElement as bs = commonElements as bs > 0

-- | remove duplicate people in a list
removeDups :: [(Tutor,Student)] -> [(Tutor,Student)]
removeDups tss = 
  foldl (\tss ts -> if eitherExists ts tss then tss else (tss ++ [ts])) [] tss
  where
    eitherExists (t,s) tss =
      (elem t (fst <$> tss)) || (elem s (snd <$> tss))

-- | pair tutors and students that have at least one subject in common
tsPairs :: [(Tutor,Student)] --[(Int,Tutor,Student)]
tsPairs = 
  (filter (\(t,s) -> hasCommonElement (tSubjects t) (sSubjects s)) $     
    (,) <$> tutors <*> students)

-- | for each list of unique Tutor-Student pairing, we calculate a score. 
-- The score for a Tutor-Student pair is higher than Subject matching so 
-- that we can eliminate lists with unoccupied Tutors.
getScore :: [(Tutor,Student)] -> Int
getScore tss = enrolledScore + sharedSubjectScore
  where
    enrolledScore = 10 * length tss
    sharedSubjectScore = sum $ (\(t,s) -> commonElements (tSubjects t) (sSubjects s)) <$> tss

optimalPairs :: [(Tutor,Student)]
optimalPairs =
  snd $ head $ getMaximumScore $
    (removeDups <$> subsequences tsPairs)
  where
    getMaximumScore =
      foldl (\prevTss tss -> 
              let newScore = getScore tss
              in if newScore > (fst $ head prevTss) then [(newScore,tss)] else prevTss
            ) [(0,[])]

prettyPrint :: [(Tutor,Student)] -> IO ()
prettyPrint = mapM_ (\(t,s) -> putStrLn (tName t ++ " -> " ++ sName s) )

main :: IO ()
main = prettyPrint $ optimalPairs


{-
-- this is a simplified version of (nub $ removeDups <$> subsequences tsPairs)
import Control.Monad (filterM)

combine xs ys = nub . concatMap (\xs' -> nub . fmap (zip xs') $ permutations ys) $ powerSet xs
  where powerSet = filterM (const [True, False])
  
-- combine such that it does not produce duplicates

combine' :: forall a b. [a] -> [b] -> [[(a, b)]]
combine' [] _  = []
combine' _ []  = []
combine' (x : xs) (y : ys) = concat (mapHole holeFn (y : ys)) ++ combine' xs (y : ys)
  where
  holeFn ls z rs = [(x, z)] : fmap ((x, z) :) subresults
    where subresults = combine' xs (ls ++ rs)

mapHole :: ([a] -> a -> [a] -> b) -> [a] -> [b]
mapHole f = aux f []
  where
  aux _ _ []        = []
  aux f ls (x : rs) = f ls x rs : aux f (ls ++ [x]) rs
-}