fradrive/test/Handler/Utils/ExamSpec.hs

{-# OPTIONS_GHC -Wwarn #-}

module Handler.Utils.ExamSpec (spec) where

import TestImport
import Data.Universe (Universe, Finite, universeF)

import ModelSpec ()     -- instance Arbitrary User

import Test.Hspec.QuickCheck (prop)

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI

import Handler.Utils.Exam

instance Arbitrary ExamOccurrence where
    arbitrary = ExamOccurrence
        <$> arbitrary   -- examOccurrenceExam
        <*> arbitrary   -- examOccurrenceName
        <*> arbitrary   -- examOccurrenceRoom
        <*> arbitrary   -- examOccurrenceRoomHidden
        <*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]]   -- examOccurrenceCapacity
        <*> arbitrary   -- examOccurrenceStart
        <*> arbitrary   -- examOccurrenceEnd
        <*> arbitrary   -- examOccurrenceDescription


data Preselection = NoPreselection | SomePreselection
    deriving stock (Show, Bounded, Enum)
    deriving anyclass (Universe, Finite)

data Nudges = NoNudges | SmallNudges | LargeNudges
    deriving stock (Show, Bounded, Enum)
    deriving anyclass (Universe, Finite)

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c

uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (a, b, c, d) = f a b c d

-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text}
    deriving (Show)

extractProperties :: User -> UserProperties
extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSurname userMatrikelnummer

-- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed.
--                       Hashable seed
--                    => seed
--                    -> ExamOccurrenceRule
--                    -> ExamAutoOccurrenceConfig
--                    -> Map ExamOccurrenceId Natural
--                    -> Map UserId (User, Maybe ExamOccurrenceId)
--                    -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
-- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
spec :: Spec
spec = do
    describe "examAutoOccurrence" $ do
        describe "Surname" $ do
            let rule :: ExamOccurrenceRule
                rule = ExamRoomSurname
            forM_ universeF $ \nudges -> describe (show nudges) $
                forM_ universeF $ \preselection ->
                    prop (show preselection) $ propertyTest rule nudges preselection
        describe "Matriculation" $ do
            let rule :: ExamOccurrenceRule
                rule = ExamRoomMatriculation
            forM_ universeF $ \nudges -> describe (show nudges) $
                forM_ universeF $ \preselection ->
                    prop (show preselection) $ propertyTest rule nudges preselection
        -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom
    where
        seed :: ()
        seed = ()
        propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
        propertyTest rule nudges preselection = do
            (users, occurrences) <- genUsersWithOccurrences preselection
            eaocNudge <- case nudges of
                NoNudges -> pure Map.empty
                SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
                                in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
                LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
                                                    (2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
                                in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
            let config :: ExamAutoOccurrenceConfig
                config = def {eaocNudge}
                (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
            pure $ ioProperty $ do
                -- every (relevant) user got assigned a room
                shouldBe (length userMap) (length users)
                let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
                    foldFn _userMapping False = False
                    foldFn (_userId, Just _occurrenceId) True = True
                    foldFn (userId, Nothing) True
                        = (rule == ExamRoomMatriculation)
                        -- every user with a userMatrikelnummer got a room
                        -- fail on unknown user
                        || (fromMaybe False $ isNothing . userMatrikelnummer . fst <$> Map.lookup userId users)
                shouldSatisfy userMap $ foldr foldFn True . Map.toList
                -- no room is overfull
                let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                    userProperties = Map.map (first extractProperties) users
                shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
                case maybeMapping of
                    -- all users match the shown ranges
                    (Just occurrenceMapping)
                        -> shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
                    -- is a nullResult justified?
                    Nothing -> shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified
        -- | generate users without any pre-assigned rooms
        genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
        genUsersWithOccurrences preselection = do
            rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary
            occurrences <- genOccurrences $ length rawUsers
            -- user surnames anpassen, sodass interessante instanz
            users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
                userSurname <- elements surnames
                assignedRoom <- case preselection of
                    NoPreselection -> pure Nothing
                    SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
                pure (entityKey, (entityVal {userSurname}, assignedRoom))
            pure (users, occurrences)
        genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
        genOccurrences numUsers = do
            -- TODO is this realistic?
            -- extra space to get nice borders
            extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
            let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
                createOccurrences acc
                    |  sum (map snd acc) < totalSpaceRequirement = do
                        Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
                        createOccurrences $ (entityKey, examOccurrenceCapacity entityVal) : acc
                    | otherwise = pure acc
            Map.fromList <$> createOccurrences []
        genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer)
        genNudge nudgesList acc occurrenceId
            = fmap appendNonZero $ frequency $ map (second pure) nudgesList
            where
                appendNonZero :: Integer -> Map ExamOccurrenceId Integer
                appendNonZero 0 = acc
                appendNonZero nudge = Map.insert occurrenceId nudge acc
        -- name list copied from test/Database/Fill.hs
        surnames :: [Text]
        surnames =   [ "Smith", "Johnson", "Williams", "Brown"
                    , "Jones", "Miller", "Davis", "Garcia"
                    , "Rodriguez", "Wilson", "Martinez", "Anderson"
                    , "Taylor", "Thomas", "Hernandez", "Moore"
                    , "Martin", "Jackson", "Thompson", "White"
                    , "Lopez", "Lee", "Gonzalez", "Harris"
                    , "Clark", "Lewis", "Robinson", "Walker"
                    , "Perez", "Hall", "Young", "Allen"
                    ]
        occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId]
        occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc)
            Map.empty $ Map.toAscList userMap
            where
                appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId]
                appendJust Nothing _userId = id
                appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
        -- | Are all rooms large enough to hold all assigned Users?
        fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                    -> Map ExamOccurrenceId Natural
                    -> Map UserId (Maybe ExamOccurrenceId)
                    -> Bool
        fitsInRooms userProperties occurrences userMap
            = all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
            where
                roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
                roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
                    Nothing -> False
                    (Just capacity) -> length userIds <= fromIntegral capacity
                                    || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
        -- | Does the (currently surname) User fit to the displayed ranges?
        -- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
        showsCorrectRanges :: ExamOccurrenceRule
                            -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                            -> ExamOccurrenceMapping ExamOccurrenceId
                            -> Map UserId (Maybe ExamOccurrenceId)
                            -> Bool
        showsCorrectRanges rule userProperties (examOccurrenceMappingMapping -> mappingRanges) userMap
            = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
            where
                userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
                userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
                    case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of
                        (_maybeRanges, Just (_userProperty, Just fixedRoomId))
                            -> roomId == fixedRoomId
                        (Just ranges, Just (UserProperties {pSurname, pMatrikelnummer}, Nothing))
                            -> any fitsInRange ranges
                            where
                                ciTag :: Maybe [CI Char]
                                ciTag = map CI.mk . Text.unpack <$> case rule of
                                    ExamRoomSurname -> Just pSurname
                                    ExamRoomMatriculation -> pMatrikelnummer
                                    _rule -> Nothing
                                fitsInRange :: ExamOccurrenceMappingDescription -> Bool
                                fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
                                    Nothing -> True
                                    (Just tag) -> eaomrStart <= tag && (take (length eaomrEnd) tag <= eaomrEnd)
                                fitsInRange ExamOccurrenceMappingSpecial {}
                                    = True      -- FIXME what is the meaning of special?
                        _otherwise -> False
        -- | Is mapping impossible?
        isNullResultJustified :: ExamOccurrenceRule
                                -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
                                -> Map ExamOccurrenceId Natural -> Bool
        isNullResultJustified rule userProperties occurrences
            = noRelevantUsers rule userProperties || mappingImpossible rule userProperties occurrences
        noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
        noRelevantUsers rule = null . Map.filter (isRelevantUser rule)
        isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
        isRelevantUser _rule (_user, Just _assignedRoom) = False
        isRelevantUser rule (UserProperties {pSurname, pMatrikelnummer}, Nothing) = case rule of
            ExamRoomSurname -> not $ null pSurname
            ExamRoomMatriculation -> maybe False (not . null) pMatrikelnummer
            _rule -> False
        mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
        mappingImpossible
            rule
            userProperties@(sort . map (ruleProperty rule . fst) . Map.elems . Map.filter (isRelevantUser rule) -> relevantUsers)
            (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go relevantUsers occurrences'
            where
                go :: [Maybe Text] -> [Natural] -> Bool
                go [] _occurrences = False
                go _remainingUsers [] = True
                go remainingUsers (0:t) = go remainingUsers t
                go remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
                    | nextUsers <= firstOccurrence = go remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences
                    | otherwise = go remainingUsers laterOccurrences
                    where
                        (fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
        ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text
        ruleProperty rule = case rule of
            ExamRoomSurname -> Just . pSurname
            ExamRoomMatriculation -> pMatrikelnummer
            _rule -> const Nothing
        -- copied and adjusted from Hander.Utils.Exam
        adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
        -- ^ reduce room capacity for every pre-assigned user by 1
        adjustOccurrences userProperties occurrences = foldl' (flip $ Map.update predToPositive) occurrences $ Map.mapMaybe snd userProperties
        -- FIXME what about capacity-0 in occurrences?
        -- what if the first word is too big for the first room?
        predToPositive :: Natural -> Maybe Natural
        predToPositive 0 = Nothing
        predToPositive 1 = Nothing
        predToPositive n = Just $ pred n