{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-incomplete-uni-patterns #-}

module Handler.Utils.Exam
  ( fetchExamAux
  , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
  , examBonus, examBonusPossible, examBonusAchieved
  , examResultBonus, examGrade
  , ExamAutoOccurrenceConfig
  , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
  , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
  , examAutoOccurrence
  ) where

import Import.NoFoundation

import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E
import Database.Esqueleto.Utils.TH

import qualified Data.Conduit.List as C

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Foldable as F

import qualified Data.CaseInsensitive as CI

import Control.Monad.Trans.Random.Lazy (evalRand)
import System.Random (mkStdGen)
import Control.Monad.Random.Class (weighted)
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.Char as Char

import qualified Data.RFC5051 as RFC5051


fetchExamAux :: ( SqlBackendCanRead backend
                , E.SqlSelect b a
                , MonadHandler m
                , Typeable a
                )
             => (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
             -> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
fetchExamAux prj tid ssh csh examn =
    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
    in  cachedBy cachId $ do
        tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
            E.on     $ course E.^. CourseId E.==. tut E.^. ExamCourse
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                E.&&.  course E.^. CourseShorthand E.==. E.val csh
                E.&&.  tut    E.^. ExamName    E.==. E.val examn
            return $ prj tut course
        case tutList of
          [tut] -> return tut
          _other  -> notFound

fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
fetchExam = fetchExamAux const

fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn

fetchCourseIdExamId  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn

fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn


examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
examBonus (Entity eId Exam{..}) = runConduit $
  let
    rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
      E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
       E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
                                                        E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
                      )
      E.on E.true
      E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
      E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
           E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
      E.where_ $ E.case_ 
        [ E.when_
            ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
          E.then_
            (       E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
              E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
            )
        ]
        ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
        )
      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
    accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
      flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
   in rawData .| accum

examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap


examResultBonus :: ExamBonusRule
                -> SheetGradeSummary -- ^ `examBonusPossible`
                -> SheetGradeSummary -- ^ `examBonusAchieved`
                -> Points
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
  ExamBonusManual{}
    -> 0
  ExamBonusPoints{..}
    -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
  where
    bonusProp :: Rational
    bonusProp
      | possible <= 0 = 1
      | otherwise = achieved / possible
      where
        achieved = toRational (getSum $ achievedPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
        possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
        
        scalePasses :: Integer -> Rational
        -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
        scalePasses passes
          | passesPossible <= 0 = 0
          | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
          where
            passesPossible = getSum $ numSheetsPasses bonusPossible
            pointsPossible = getSum $ sumSheetsPoints bonusPossible

    roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a
    -- ^ 'round-to-nearest' whole multiple
    roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw)
      = MkFixed . (* mult') $
          let (whole, frac) = raw `divMod'` mult
           in if | abs frac < abs (mult / 2)
                   -> whole
                 | raw >= 0
                   -> succ whole
                 | otherwise
                   -> pred whole
 
examGrade :: ( MonoFoldable mono
             , Element mono ~ ExamResultPoints
             )
          => Exam
          -> Maybe Points -- ^ Bonus
          -> mono -- ^ `ExamPartResult`s
          -> Maybe ExamResultGrade
examGrade Exam{..} mBonus (otoList -> results)
  = traverse pointsToGrade achievedPoints'
  where
    achievedPoints' :: ExamResultPoints
    achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results

    withBonus :: Points -> Points
    withBonus ps
      | Just bonusRule <- examBonusRule
      = if
          |    maybe True not (bonusRule ^? _bonusOnlyPassed)
            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
            -> maybe id (+) mBonus ps
          | otherwise
            -> ps
      | otherwise
      = ps
    
    pointsToGrade :: Points -> Maybe ExamGrade
    pointsToGrade ps = examGradingRule <&> \case
      ExamGradingKey{..}
        -> gradeFromKey examGradingKey
      where
        gradeFromKey :: [Points] -> ExamGrade
        gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
          where
            lowerBounds :: [(ExamGrade, Points)]
            lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'

data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
  { eaocMinimizeRooms :: Bool
  , eaocFinenessCost  :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
  , eaocNudge         :: Map ExamOccurrenceId Integer
  , eaocNudgeSize     :: Rational
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Default ExamAutoOccurrenceConfig where
  def = ExamAutoOccurrenceConfig
    { eaocMinimizeRooms = False
    , eaocFinenessCost  = 0.2
    , eaocNudge         = Map.empty
    , eaocNudgeSize     = 0.05
    }

makeLenses_ ''ExamAutoOccurrenceConfig

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamAutoOccurrenceConfig
        

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
  | sum occurrences < usersCount
    || sum occurrences <= 0
    || Map.null users
  = nullResult
  | otherwise
  = case rule of
      ExamRoomRandom
        -> ( Nothing
           , flip Map.mapWithKey users $ \uid (_, mOcc)
               -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
                        weighted $ over _2 fromIntegral <$> occurrences'
                   in Just $ fromMaybe randomOcc mOcc
           )
      _ | Just (postprocess -> (resMapping, result)) <- bestOption
          -> ( Just $ ExamOccurrenceMapping rule resMapping
             , Map.unionWith (<|>) (view _2 <$> users) result
             )
      _ -> 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)
           | (uid, (User{..}, Nothing)) <- Map.toList users
           , not $ null userSurname
           ]
      ExamRoomMatriculation
        -> let matrUsers
                 = Map.fromListWith Set.union
                   [ (map CI.mk $ unpack matriculation', Set.singleton uid)
                   | (uid, (User{..}, Nothing)) <- Map.toList users
                   , matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
                   ]
            in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
      _ -> Map.singleton [] $ Map.keysSet users


    occurrences' :: [(ExamOccurrenceId, Natural)]
    -- ^ Minimise number of occurrences used
    --
    -- Prefer occurrences with higher capacity
    --
    -- If a single occurrence can accomodate all participants, pick the one with
    -- the least capacity
    occurrences'
      | not eaocMinimizeRooms
      = Map.toList occurrences
      | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
      = pure $ minimumBy (comparing $ view _2) largeEnoughs
      | otherwise
      = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences
      where
        accF :: (Natural, [(ExamOccurrenceId, Natural)])
             -> (ExamOccurrenceId, Natural)
             -> (Natural, [(ExamOccurrenceId, Natural)])
        accF acc@(accSize, accOccs) occ@(_, occSize)
          | accSize >= usersCount
          = acc
          | otherwise
          = ( accSize + occSize
            , occ : accOccs
            )

    distribute :: forall wordId lineId cost.
                  _
               => [(wordId, Natural)] -- ^ Word sizes (in order)
               -> [(lineId, Natural)] -- ^ Line sizes (in order)
               -> (lineId -> Integer) -- ^ Nudge
               -> (wordId -> wordId -> Extended Rational) -- ^ Break cost
               -> Maybe (cost, [(lineId, [wordId])])
    -- ^ Distribute the given items (@wordId@s) with associated size in
    -- contiguous blocks into the given buckets (@lineId@s) such that they are
    -- filled as evenly as possible (proportionally)
    --
    -- Return a cost scaled to item-size squared
    --
    -- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
    distribute wordLengths lineLengths lineNudge breakCost
      | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ])
      | null lineLengths = Nothing
      | otherwise        = let (cost, result) = distribute'
                            in case cost of
                                 Finite c -> Just (fromInteger $ round c, result)
                                 _other   -> Nothing
      where
        longestLine :: Natural
        -- ^ For scaling costs
        longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths

        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, [(lineId, [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 (l, potWidth)
                          | lineIx >= 0
                          , lineIx < length lineLengths
                          = over _1 Just $ lineLengths List.!! lineIx
                          | otherwise
                          = (Nothing, 0)
                        w = offsets Array.! j - offsets Array.! i
                    prevMin <- ST.readArray minima i
                    let cost = prevMin + widthCost l potWidth w + breakCost'
                        breakCost'
                          | j < Map.size wordMap
                          , j > 0
                          = breakCost (wordIx # pred j) (wordIx # j)
                          | otherwise
                          = 0
                    -- traceM $ show ( i
                    --               , j
                    --               , potWidth
                    --               , w
                    --               , (fromRational :: Rational -> Centi) <$> prevMin
                    --               , (fromRational :: Rational -> Centi) <$> widthCost potWidth w
                    --               , (fromRational :: Rational -> Centi) <$> breakCost'
                    --               )
                    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 . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
            -- 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 ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
                let accMap' = (lineIxs List.!! lineIx, 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, [])
                

        widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational
        widthCost l lineWidth w
          | lineWidth < w = PosInf
          | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2
          where
            optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths)
            optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio

    charCost :: [CI Char] -> [CI Char] -> Extended Rational
    charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
      where
        longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences'

  
    lcp :: Eq a => [a] -> [a] -> [a]
    -- ^ Longest common prefix
    lcp [] _ = []
    lcp _ [] = []
    lcp (a:as) (b:bs)
      | a == b    = a:lcp as bs
      | otherwise = []

    lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge

    bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
    bestOption = case rule of
      ExamRoomSurname -> do
        (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
        -- traceM $ show cost
        return res
      ExamRoomMatriculation -> do
        let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users'
            -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'

            distributeFine :: Natural -> Maybe (Extended Rational, _)
            distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost

            maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'

            resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural
            resultFineness (map (view _2) -> res)
              | Just res' <- fromNullable res
              = maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res')
              | otherwise = 0
              where
                transFineness :: [[CI Char]] -> [[CI Char]] -> Natural
                transFineness nsA nsB
                  | Just maxA <- nsA ^? _last
                  , Just minB <- nsB ^? _head
                  = succ . List.genericLength $ maxA `lcp` minB
                  | otherwise
                  = 0

            genResults f
              | f > maximumFineness = []
              | otherwise =
                let mRes = distributeFine f
                 in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness)

        (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
        return res
      _other -> Nothing

    postprocess :: [(ExamOccurrenceId, [[CI Char]])]
                -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
                   , Map UserId (Maybe ExamOccurrenceId)
                   )
    postprocess result = (resultAscList, resultUsers)
      where
        resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result
          where
            accRes _ [] = []
            accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
              | Just minA <- prevEnd <|> preview _head nsA
              , Just maxA <- nsA ^? _last
              , Just minB <- nsB ^? _head
              = let common = maxA `lcp` minB
                 in if
                  | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last
                  , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head
                  , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head
                  , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA
                  , firstB : _ <- CI.foldedCase <$> drop (length common) rminB
                    -> let break'
                             | occSize occA > 0 || occSize occB > 0
                             = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
                                 & floor
                                 & Char.chr
                                 & Char.toUpper
                                 & CI.mk
                                 & pure
                                 & (common ++)
                             | otherwise = common ++ pure (CI.mk firstA)
                           succBreak = fmap reverse . go $ reverse break'
                             where
                               go [] = Nothing
                               go (c:cs)
                                 | c' <- CI.map succ c
                                 , c' `Set.member` rangeAlphabet
                                 = Just $ c' : cs
                                 | otherwise
                                 = go cs
                           commonLength = max 1 . succ . length $ minA `lcp` break'
                           isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA  `lcp` c) >= pred (length rminA )
                           isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break')
                           rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA
                           breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA
                           breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA
                        in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs)
                  | otherwise
                    -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs)
              | null nsA
              = accRes prevEnd $ (occB, nsB) : xs
              | otherwise -- null nsB
              = accRes prevEnd $ (occA, nsA) : xs
            accRes prevEnd [(occZ, nsZ)]
              | Just minAlpha <- Set.lookupMin rangeAlphabet
              , Just maxAlpha <- Set.lookupMax rangeAlphabet
              , minZ <- fromMaybe (pure minAlpha) prevEnd
              = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ
                    isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ)
                    rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ
                    breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ
                 in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials)
              | otherwise
              = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
        resultUsers = Map.fromList $ do
          (occId, buckets) <- result
          let matchWord b b' = case rule of
                ExamRoomMatriculation
                  -> b `isSuffixOf` b'
                _other
                  -> b == b'
          user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
          return (user, Just occId)

        occSize :: Num a => ExamOccurrenceId -> a
        occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers
        
        rangeAlphabet :: Set (CI Char)
        rangeAlphabet
          | ExamRoomSurname <- rule
          = Set.fromList $ map CI.mk ['A'..'Z']
          | ExamRoomMatriculation <- rule
          = Set.fromList $ map CI.mk ['0'..'9']
          | otherwise
          = mempty
        mayRange :: Int -> [CI Char] -> Bool
        mayRange l = all (`Set.member` rangeAlphabet) . take l

        pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
        pad res
          | ExamRoomMatriculation <- rule
          , Just minAlpha <- Set.lookupMin rangeAlphabet
          = let maxLength = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
                padSuff cs = replicate (maxLength - length cs) minAlpha ++ cs
             in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
          | otherwise
          = res