feat(exam): working prototype of automatic occurrence assignment

package.yaml

@@ -137,6 +137,7 @@ dependencies:
   - prometheus-client
   - prometheus-metrics-ghc
   - wai-middleware-prometheus
+  - extended-reals
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
+                       weightedMay $ over _2 fromIntegral <$> occurrences'
-                   in Just $ fromMaybe randomOcc mOcc
+                   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
+                   , let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer
-                           , not $ null matriculation
+                   , 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
+    -- ^ Partition users into monotonously finer
-    usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users' 
+    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 :: (Natural, [(ExamOccurrenceId, Natural)])
-        
+             -> (ExamOccurrenceId, Natural)
-        accF :: (ExamOccurrenceId, Natural)
              -> (Natural, [(ExamOccurrenceId, Natural)])
-             -> (Natural, [(ExamOccurrenceId, Natural)])
+        accF acc@(accSize, accOccs) occ@(_, occSize)
-        accF occ@(_, occSize) acc@(accSize, accOccs)
           | 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)

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

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
+createUser = runDB . insertEntity . fakeUser
-  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{..}
 
 lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec
 lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))

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