diff --git a/package.yaml b/package.yaml index e2e15ec82..f8d437c20 100644 --- a/package.yaml +++ b/package.yaml @@ -137,6 +137,7 @@ dependencies: - prometheus-client - prometheus-metrics-ghc - wai-middleware-prometheus + - extended-reals other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index d3cdd4278..f4d1d32d9 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -26,7 +26,22 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Random.Lazy (evalRand) import System.Random (mkStdGen) -import Control.Monad.Random.Class (uniform) +import Control.Monad.Random.Class (weightedMay) +import Control.Monad.ST (ST, runST) + +import Data.Array (Array) +import qualified Data.Array as Array + +import Data.Array.ST (STArray, STUArray) +import qualified Data.Array.ST as ST + +import Data.List (findIndex, unfoldr) +import qualified Data.List as List + +import Data.ExtendedReal + +import qualified Data.Text as Text +import qualified Data.Char as Char fetchExamAux :: ( SqlBackendCanRead backend @@ -179,7 +194,7 @@ examAutoOccurrence :: forall seed. -> Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) examAutoOccurrence (hash -> seed) rule occurrences users - | sum occurrences < fromIntegral (Map.size users) + | sum occurrences < usersCount || Map.null users = nullResult | otherwise @@ -188,8 +203,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -> ( Nothing , flip Map.mapWithKey users $ \uid (_, mOcc) -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ - uniform $ Map.keysSet occurrences - in Just $ fromMaybe randomOcc mOcc + weightedMay $ over _2 fromIntegral <$> occurrences' + in mOcc <|> randomOcc ) _ | Just (postprocess -> (resMapping, result)) <- bestOption -> ( Just $ ExamOccurrenceMapping rule resMapping @@ -198,31 +213,42 @@ examAutoOccurrence (hash -> seed) rule occurrences users _ -> nullResult where nullResult = (Nothing, view _2 <$> users) - + usersCount :: forall a. Num a => a + usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' + users' :: Map [CI Char] (Set UserId) -- ^ Finest partition of users users' = case rule of ExamRoomSurname -> Map.fromListWith Set.union - [ (map CI.mk $ unpack userSurname, Set.singleton uid) + [ (map CI.mk $ unpack userSurname', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , not $ null userSurname + , let userSurname' = Text.filter Char.isLetter userSurname + , not $ null userSurname' ] ExamRoomMatriculation -> let matrUsers = Map.fromListWith Set.union - [ (map CI.mk . reverse $ unpack matriculation, Set.singleton uid) + [ (map CI.mk $ unpack matriculation', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let Just matriculation = userMatrikelnummer - , not $ null matriculation + , let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer + , not $ null matriculation' ] in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers _ -> Map.singleton [] $ Map.keysSet users usersGroups :: Natural -- ^ fineness -> Map [CI Char] (Set UserId) - -- ^ Partition users into monotonously finer partitions - usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users' + -- ^ Partition users into monotonously finer + usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union restr users' + where + restr = case rule of + ExamRoomSurname + -> take c + ExamRoomMatriculation + -> reverse . take c . reverse + _other + -> id maximumFineness :: Natural -- ^ Fineness at which `usersGroups` becomes constant @@ -239,19 +265,17 @@ examAutoOccurrence (hash -> seed) rule occurrences users | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences = pure $ minimumBy (comparing $ view _2) largeEnoughs | otherwise - = view _2 . foldr accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences + = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences where - usersCount = fromIntegral $ Map.size users - - accF :: (ExamOccurrenceId, Natural) + accF :: (Natural, [(ExamOccurrenceId, Natural)]) + -> (ExamOccurrenceId, Natural) -> (Natural, [(ExamOccurrenceId, Natural)]) - -> (Natural, [(ExamOccurrenceId, Natural)]) - accF occ@(_, occSize) acc@(accSize, accOccs) + accF acc@(accSize, accOccs) occ@(_, occSize) | accSize >= usersCount = acc | otherwise = ( accSize + occSize - , accOccs ++ [occ] + , occ : accOccs ) largestOccurrence :: Num a => a @@ -262,7 +286,7 @@ examAutoOccurrence (hash -> seed) rule occurrences users where finenessConst :: Rational -- ^ Cost (scaled to proportion of occurrence) of having higher fineness - finenessConst = 1 % 20 -- TODO: tweak + finenessConst = 1 % 5 -- TODO: tweak distribute :: forall wordId lineId cost. @@ -282,26 +306,121 @@ examAutoOccurrence (hash -> seed) rule occurrences users distribute wordLengths lineLengths | null wordLengths = Just (0, Map.empty) | null lineLengths = Nothing - | otherwise = Just distribute' + | otherwise = let (cost, result) = distribute' + in case cost of + Finite c -> Just (fromInteger $ round c, result) + _other -> Nothing where - _longestLine :: cost + longestLine :: Natural -- ^ For scaling costs - _longestLine = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull lineLengths + longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths - distribute' = error "not implemented" -- TODO: implement + wordMap :: Map wordId Natural + wordMap = Map.fromListWith (+) wordLengths + + wordIx :: Iso' wordId Int + wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords + in ix' + ) + (collapsedWords Array.!) + + collapsedWords :: Array Int wordId + collapsedWords = Array.array + (0, pred $ Map.size wordMap) + [ (ix', wId) + | wId <- Map.keys wordMap + , let Just ix' = findIndex ((== wId) . view _1) wordLengths + ] + + offsets :: Array Int Natural + offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0) + where + accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int)) + accOffsets accSize ix' + | ix' <= 0 = Just (0, (0, 1)) + | Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix') + in Just (newSize, (newSize, succ ix')) + | otherwise = Nothing + + bounds = (0, Map.size wordMap) + + distribute' :: (Extended Rational, Map lineId (Set wordId)) + distribute' = runST $ do + minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) + breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) + + forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do + let go i j + | j <= Map.size wordMap = do + let + walkBack 0 = return 0 + walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' + lineIx <- walkBack i + let potWidth + | lineIx >= 0 + , lineIx < length lineLengths + = view _2 $ lineLengths List.!! lineIx + | otherwise + = 0 + w = offsets Array.! j - offsets Array.! i + cost <- (+) (widthCost potWidth w) <$> ST.readArray minima i + when (isFinite cost) $ do + minCost <- ST.readArray minima j + when (cost < minCost) $ do + ST.writeArray minima j cost + ST.writeArray breaks j i + go i' $ succ j + | otherwise = return () + in go i' $ succ i' + traceM . show =<< ST.getElems breaks + + let accumResult lineIx j (accCost, accMap) = do + i <- ST.readArray breaks j + accCost' <- (+) accCost <$> ST.readArray minima j + traceM $ show (accCost', lineIx, [i .. pred j]) + let accMap' = Map.insertWith Set.union (lineIxs List.!! lineIx) (Set.fromList $ map (review wordIx) [i .. pred j]) accMap + if + | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') + | otherwise -> return (accCost', accMap') + lineIxs = reverse $ map (view _1) lineLengths + in accumResult 0 (Map.size wordMap) (0, Map.empty) + + + widthCost :: Natural -> Natural -> Extended Rational + widthCost lineWidth w + | lineWidth < w = PosInf + | otherwise = Finite (((fromIntegral lineWidth % fromIntegral w) - optimumRatio) * fromIntegral longestLine) ^ 2 + where + optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) lineLengths) (map (view _2) wordLengths) options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))] options = do fineness <- [0..maximumFineness] + + let usersGroups' = fromIntegral . Set.size <$> usersGroups fineness + + traceM $ show usersGroups' + traceM . show $ map snd occurrences' + + -- The algorithm used in `distribute` produces no usable result if the + -- situation occurs, that a single item does not fit within a bucket. + -- In a naive attempt to prevent this we ensure that all items fit into + -- all buckets. + guard . (\(fromIntegral -> maxSize) -> all ((>= maxSize) . view _2) occurrences') . maybe 0 maximum $ fromNullable usersGroups' + let packets :: [([CI Char], Natural)] - packets = Map.toAscList . fmap (fromIntegral . Set.size) $ usersGroups fineness + packets = Map.toAscList usersGroups' (resultCost, result) <- hoistMaybe $ distribute packets occurrences' + + traceM $ show (fineness, finenessCost fineness, resultCost) + traceM . show . map (foldMap $ \prefix -> Sum $ usersGroups' Map.! prefix) $ Map.elems result + return (fineness, (resultCost, result)) bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char])) bestOption = options - & takeWhile (\(fineness, (resCost, _)) -> finenessCost fineness < resCost) + & over _tail (takeWhile $ \(fineness, (resCost, _)) -> finenessCost fineness <= resCost) & map (view $ _2 . _2) & fmap last . fromNullable @@ -314,5 +433,5 @@ examAutoOccurrence (hash -> seed) rule occurrences users resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result resultUsers = Map.fromList $ do (occId, buckets) <- Map.toList result - user <- Set.toList $ foldMap (flip (Map.findWithDefault Set.empty) users') buckets + user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b `List.isPrefixOf` b') $ Map.toList users') buckets return (user, Just occId) diff --git a/stack.yaml b/stack.yaml index 2764abce4..d0852e051 100644 --- a/stack.yaml +++ b/stack.yaml @@ -67,5 +67,7 @@ extra-deps: - prometheus-metrics-ghc-1.0.0 - wai-middleware-prometheus-1.0.0 + - extended-reals-0.2.3.0 + resolver: lts-13.21 allow-newer: true diff --git a/test/TestImport.hs b/test/TestImport.hs index 2b13743ab..9106ec67e 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -47,6 +47,7 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) +import User as X (fakeUser) import Control.Monad.Catch as X hiding (Handler(..)) @@ -118,37 +119,7 @@ authenticateAs (Entity _ User{..}) = do -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. createUser :: (User -> User) -> YesodExample UniWorX (Entity User) -createUser adjUser = do - UserDefaultConf{..} <- appUserDefaults . view appSettings <$> getTestYesod - now <- liftIO getCurrentTime - let - userMatrikelnummer = Nothing - userAuthentication = AuthLDAP - userLastAuthentication = Nothing - userTokensIssuedAfter = Nothing - userIdent = "dummy@example.invalid" - userEmail = "dummy@example.invalid" - userDisplayEmail = "dummy@example.invalid" - userDisplayName = "Dummy Example" - userSurname = "Example" - userFirstName = "Dummy" - userTitle = Nothing - userTheme = userDefaultTheme - userMaxFavourites = userDefaultMaxFavourites - userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - userDateTimeFormat = userDefaultDateTimeFormat - userDateFormat = userDefaultDateFormat - userTimeFormat = userDefaultTimeFormat - userDownloadFiles = userDefaultDownloadFiles - userWarningDays = userDefaultWarningDays - userShowSex = userDefaultShowSex - userLanguages = Nothing - userNotificationSettings = def - userCreated = now - userLastLdapSynchronisation = Nothing - userCsvOptions = def - userSex = Nothing - runDB . insertEntity $ adjUser User{..} +createUser = runDB . insertEntity . fakeUser lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p)) diff --git a/test/User.hs b/test/User.hs new file mode 100644 index 000000000..1efb8d673 --- /dev/null +++ b/test/User.hs @@ -0,0 +1,40 @@ +module User + ( fakeUser + ) where + +import ClassyPrelude + +import Settings +import Model + +import Data.Default +import System.IO.Unsafe + + +fakeUser :: (User -> User) -> User +fakeUser adjUser = adjUser User{..} + where + UserDefaultConf{..} = appUserDefaults compileTimeAppSettings + + userMatrikelnummer = Nothing + userAuthentication = AuthLDAP + userLastAuthentication = Nothing + userTokensIssuedAfter = Nothing + userIdent = "dummy@example.invalid" + userEmail = "dummy@example.invalid" + userDisplayEmail = "dummy@example.invalid" + userDisplayName = "Dummy Example" + userSurname = "Example" + userFirstName = "Dummy" + userTitle = Nothing + userTheme = userDefaultTheme + userMaxFavourites = userDefaultMaxFavourites + userDateTimeFormat = userDefaultDateTimeFormat + userDateFormat = userDefaultDateFormat + userTimeFormat = userDefaultTimeFormat + userDownloadFiles = userDefaultDownloadFiles + userWarningDays = userDefaultWarningDays + userMailLanguages = def + userNotificationSettings = def + userCreated = unsafePerformIO getCurrentTime + userLastLdapSynchronisation = Nothing