{-# 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

-- TODO
-- use frequency instead of elements?
-- are these capacity values realistic?
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

-- | 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}
                result@(_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
                -- all users match the shown ranges
                shouldSatisfy (rule, userProperties, result) $ uncurry3 showsCorrectRanges
        -- | 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)
                            -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
                            -> Bool
        showsCorrectRanges _rule _userProperties (Nothing, _userMap) = False
        showsCorrectRanges rule userProperties (Just (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