Solving Code Jam 2020 Qualification Round - https://codingcompetitions.withgoogle.com/codejam/round/000000000019fd27/000000000020bdf9

parenting partnering.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Control.Lens (cloneLens, makeLenses, use, (.=))
import Control.Monad (guard, msum, replicateM)
import Control.Monad.Logic (MonadLogic (msplit), observeT)
import Control.Monad.State.Lazy (MonadState, evalState)
import Data.List (sortOn)

type Tag = Int

data Worker = J | C deriving (Show)

type Time = Int

type Period = (Time, Time)

data AssignState = AssignState
  { _jamie :: Maybe Period,
    _cameron :: Maybe Period
  }
  deriving (Show)

makeLenses ''AssignState

main :: IO ()
main =
  readBlock (readBlock getTimeSlot)
    >>= mapM_ putStrLn . zipWith msg [1 ..] . map assign
  where
    readBlock :: IO a -> IO [a]
    readBlock m = getLine >>= (`replicateM` m) . read

    getTimeSlot :: IO (Int, Int)
    getTimeSlot = listToTuple . map read . words <$> getLine

    msg n xs = "Case #" ++ show n ++ ": " ++ maybe "Impossible" (concatMap show) xs

    listToTuple [a, b] = (a, b)

assign :: [Period] -> Maybe [Worker]
assign = runM . extract . fmap post . mapM assign' . pre
  where
    pre = sortOn snd . zip [1 ..]
    post = map snd . sortOn fst

    initialState = AssignState Nothing Nothing

    runM = (`evalState` initialState) . observeT
    extract = fmap (fmap fst) . msplit

assign' :: (MonadState AssignState m, MonadLogic m) => (Tag, Period) -> m (Tag, Worker)
assign' (tag, slot) = do
  (worker, workerL) <- choose [(J, jamie), (C, cameron)]

  use (cloneLens workerL) >>= guard . available

  cloneLens workerL .= Just slot

  return (tag, worker)
  
  where
    choose = msum . map return
    available = maybe True (not . overlaps slot)

    overlaps :: Period -> Period -> Bool
    overlaps (x, y) (x', y') = max x x' < min y y'

FIX NEEDED! Backtracking causes worst-case performance to be in exponential time