A Haskell program that parses Doodle responses and selects the two best time slots such that as many participants as possible may attend.

Schedule.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Data.Aeson (FromJSON, Object, Value (..), eitherDecodeFileStrict, parseJSON, (.:))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Hashable
import Data.List (sort)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (dayOfWeek)
import Data.Time.Clock
import Data.Time.Format.ISO8601
import Data.Time.LocalTime
import Debug.Trace
import GHC.Generics (Generic)

data Day
    = Monday
    | Tuesday
    | Wednesday
    | Thursday
    | Friday
    deriving (Show, Ord, Eq, Bounded, Enum, Generic, Hashable)

allDays :: [Day]
allDays = [minBound .. maxBound]

numDays :: Int
numDays = fromEnum (maxBound :: Day) - fromEnum (minBound :: Day) + 1

data Hour
    = H08
    | H09
    | H10
    | H11
    | H12
    | H13
    | H14
    | H15
    | H16
    | H17
    deriving (Show, Ord, Eq, Bounded, Enum, Generic, Hashable)

allHours :: [Hour]
allHours = [minBound .. maxBound]

numHours :: Int
numHours = fromEnum (maxBound :: Hour) - fromEnum (minBound :: Hour) + 1

data Time = Time Day Hour deriving (Show, Ord, Eq, Bounded, Generic, Hashable)

allTimes :: [Time]
allTimes = [Time day hour | day <- allDays, hour <- allHours]

instance Enum Time where
    fromEnum (Time d h) = numHours * fromEnum d + fromEnum h
    toEnum i = Time (toEnum $ (i `div` numHours) `rem` numDays) (toEnum $ i `rem` numHours)

data Person = Person
    { name :: String
    }
    deriving (Show, Eq, Ord, Generic, Hashable)

data PersonNode = PersonNode
    { person :: Person
    , attending :: HashSet Time
    }
    deriving (Show)

data TimeNode = TimeNode
    { time :: Time
    , attendees :: HashSet Person
    }
    deriving (Show)

data BiGraph = BiGraph
    { people :: HashMap Person PersonNode
    , times :: HashMap Time TimeNode
    }
    deriving (Show)

emptyGraph :: BiGraph
emptyGraph = BiGraph (HashMap.empty) (HashMap.empty)

newPersonNode :: Person -> PersonNode
newPersonNode p = PersonNode p HashSet.empty

newTimeNode :: Time -> TimeNode
newTimeNode t = TimeNode t HashSet.empty

addPerson :: Person -> BiGraph -> BiGraph
addPerson p g@BiGraph{people}
    | HashMap.member p people = g
    | otherwise = g{people = people'}
  where
    people' = HashMap.insert p (newPersonNode p) people

removePerson :: Person -> BiGraph -> BiGraph
removePerson p g@BiGraph{..}
    | not (HashMap.member p people) = g
    | otherwise = g{people = people', times = times'}
  where
    attendances = maybe [] (HashSet.toList . attending) (HashMap.lookup p people)
    people' = HashMap.delete p people
    times' = foldr (HashMap.update removeAttendee) times attendances
    removeAttendee tn@TimeNode{..} = Just $ tn{attendees = HashSet.delete p attendees}

addTime :: Time -> BiGraph -> BiGraph
addTime t g@BiGraph{times}
    | HashMap.member t times = g
    | otherwise = g{times = times'}
  where
    times' = HashMap.insert t (newTimeNode t) times

removeTime :: Time -> BiGraph -> BiGraph
removeTime t g@BiGraph{..}
    | not (HashMap.member t times) = g
    | otherwise = g{people = people', times = times'}
  where
    attendees' = maybe [] (HashSet.toList . attendees) (HashMap.lookup t times)
    times' = HashMap.delete t times
    people' = foldr (HashMap.update removeAttendance) people attendees'
    removeAttendance pn@PersonNode{..} = Just $ pn{attending = HashSet.delete t attending}

addAttendance :: (Person, Time) -> BiGraph -> BiGraph
addAttendance (p, t) g = do
    BiGraph
        { people = HashMap.adjust addAttending p $ people g'
        , times = HashMap.adjust addAttendee t $ times g'
        }
  where
    g' = (addPerson p . addTime t) g
    addAttending n@PersonNode{attending} = n{attending = HashSet.insert t attending}
    addAttendee n@TimeNode{attendees} = n{attendees = HashSet.insert p attendees}

data Participant = Participant
    { participantName :: String
    , participantVotes :: [Vote]
    }
    deriving (Show, Generic)

instance FromJSON Participant where
    parseJSON (Object v) =
        Participant
            <$> v .: "name"
            <*> v .: "votes"
    parseJSON _ = mempty

data Vote = Vote
    { voteOptionId :: String
    , voteType :: VoteType
    }
    deriving (Show, Generic)

instance FromJSON Vote where
    parseJSON (Object v) =
        Vote
            <$> v .: "optionId"
            <*> v .: "type"
    parseJSON _ = mempty

data VoteType = Yes | No | Maybe deriving (Show, Eq, Generic)

instance FromJSON VoteType where
    parseJSON (String "YES") = return Yes
    parseJSON (String "NO") = return No
    parseJSON (String "IF_NEED_BE") = return Maybe
    parseJSON _ = mempty

newtype Participants = Participants {participants :: [Participant]} deriving (Show, Generic, FromJSON)

data Option = Option
    { optionId :: String
    , optionTime :: Time
    }
    deriving (Show, Generic)

instance FromJSON Option where
    parseJSON (Object v) =
        Option
            <$> v .: "id"
            <*> v .: "startAt"
    parseJSON _ = mempty

instance FromJSON Time where
    parseJSON (String s) = do
        utcTime <- iso8601ParseM $ Text.unpack s
        let cest = TimeZone 120 True "CEST"
        let LocalTime{localDay, localTimeOfDay} = utcToLocalTime cest utcTime
        let day = toEnum $ fromEnum (dayOfWeek localDay) - 1
        let hour = toEnum $ todHour localTimeOfDay - 8
        return $ Time day hour
    parseJSON _ = mempty

newtype Options = Options {options :: HashMap String Time} deriving (Show, Generic)

instance FromJSON Main.Options where
    parseJSON (Object v) = do
        options :: [Option] <- v .: "options"
        return $
            Options
                { options = HashMap.fromList $ (\Option{..} -> (optionId, optionTime)) <$> options
                }
    parseJSON _ = mempty

participantToPerson :: Participant -> Person
participantToPerson Participant{..} =
    Person
        { name = participantName
        }

voteToTime :: Vote -> HashMap String Time -> Maybe Time
voteToTime Vote{..} options = HashMap.lookup voteOptionId options

chooseTime :: Time -> BiGraph -> (BiGraph, [Person])
chooseTime t g@BiGraph{..} = (g', attendees')
  where
    attendees' = maybe [] (HashSet.toList . attendees) (HashMap.lookup t times)
    g' = foldr removePerson (removeTime t g) attendees'

data Result = Result
    { t1 :: Time
    , t2 :: Time
    , p1 :: [Person]
    , p2 :: [Person]
    , missing :: [Person]
    }
    deriving (Eq)

instance Show Result where
    show Result{..} =
        unlines $
            [show t1 <> ": " <> show n1 <> " attendees"]
                ++ names p1
                ++ [show t2 <> ": " <> show n2 <> " attendees"]
                ++ names p2
                ++ [show total <> " total attendees, " <> show n3 <> " missing"]
                ++ names missing
      where
        total = n1 + n2
        (n1, n2, n3) = (length p1, length p2, length missing)
        names ps = ("    " <>) <$> show <$> sort ps

score :: Result -> Int
score Result{..} = total ^ 2 - delta
  where
    (n1, n2) = (length p1, length p2)
    total = n1 + n2
    delta = abs $ n1 - n2

instance Ord Result where
    compare r1 r2 = compare (score r1) (score r2)

main :: IO ()
main = do
    Participants participants <- either error id <$> eitherDecodeFileStrict "./participants.json"
    Options options <- either error id <$> eitherDecodeFileStrict "./options.json"
    let attendances =
            [ (person, time)
            | p <- participants
            , let person = participantToPerson p
            , v <- participantVotes p
            , voteType v /= No
            , let Just time = voteToTime v options
            ]
    let g = foldr addAttendance emptyGraph attendances
    let result =
            maximum
                [ Result t1 t2 p1 p2 missing
                | t1 <- allTimes
                , t2 <- allTimes
                , t2 /= t1
                , let (g1, p1) = chooseTime t1 g
                , let (g2, p2) = chooseTime t2 g1
                , let missing = HashMap.keys $ people g2
                ]
    print result