Pasted

-- Rhyme.hs
module Main where
 
    import Data.Char
    import Data.List
    import Data.Array
    import Data.Function
    import Data.List.Split
    import Data.String.Utils
 
    import System.IO
 
    import BestMatching
 
    testInput = "Боже! думает бедняк,\nБедный Ваня еле дышит,\nВесь в поту, от страха бледный,\nВ темноте пред ним собака\n(Вы представьте Вани злость!)\nВаня стал; - шагнуть не может.\nГоре! малый я не сильный;\nЕсли сам земли могильной\nКрасногубый вурдалак.\nКто-то кость, ворча, грызёт.\nНа могиле гложет кость.\nПо могилам; вдруг он слышит, -\nРаз он позднею порой,\nСпотыкаясь, чуть бредёт\nСъест упырь меня совсем,\nТрусоват был Ваня бедный:\nЧрез кладбище шёл домой.\nЧто же? вместо вурдалака -\nЭто, верно, кости гложет\nЯ с молитвою не съем."
    testInputLines = splitOn "\n" testInput
 
    editDistance xs ys = table ! (m, n)
        where
            (m, n) = (length xs, length ys)
            x = array (1, m) (zip [1..] xs)
            y = array (1, n) (zip [1..] ys)
 
            table = array bnds [(ij, dist ij) | ij <- range bnds]
            bnds = ((0, 0), (m, n))
 
            dist (0, j) = j
            dist (i, 0) = i
            dist (i, j) = minimum [table ! (i - 1, j) + 1, table ! (i, j - 1) + 1,
                if x ! i == y ! j then table ! (i - 1, j - 1) else 1 + table ! (i - 1, j - 1)]
 
    transcription = transcription' . (' ':) . filter (`elem` ' ':'\n':'ё':['а'..'я']) . map toLower
        where
            rules = [
                ("ьё", "'jо"), ("ье", "'jэ"), ("ья", "'jа"), ("ью", "'jу"), ("ъё", "jо"), ("ъе", "jэ"), ("ъя", "jа"), (" ю", "jу"), (" ё", "jо"), (" е", "jэ"),
                (" я", "jа"), (" ю", "jу"), ("ё", "'о"), ("е", "'э"), ("я", "'а"), ("ю", "'у"), ("й", "j"), ("ъ", ""), ("ь", "'"), ("жи", "жы"), ("ши", "шы")
                ]
            transcription' s = foldl (\ s (src, dst) -> replace src dst s) s rules
 
    syllableCount = length . filter (`elem` "ёуеыаоэяию") . map toLower
 
    groupBySyllableCount = map (map fst) . groupBy ((==) `on` snd) . sortBy (compare `on` snd) . map (\ s -> (s, syllableCount s))
 
    transcriptionEndingLength = 5
 
    getRhymablePart = take transcriptionEndingLength . filter (`notElem` " ") . reverse . transcription
    
    orderByRhyme = filter (\ (s1, s2) -> s1 < s2) . rhymeMatcher
        where
            rhymeMatcher lines = findBestMatching (\ s1 s2 -> if s1 == s2 then 1000 else (editDistance `on` getRhymablePart) s1 s2) lines lines
 
    solve = concatGroups [] . reorder . map process . splitOn "\n"
        where
            process line = (line, getRhymablePart line, syllableCount line)
            groupLines = map (map (\ (x, _, _) -> x)) . sortBy (compare `on` length) . groupBy (\ (_, _, x1) (_, _, x2) -> x1 == x2) . sortBy (\ (_, _, x1) (_, _, x2) -> compare x2 x1)
            reorder = map reorderGroup . map (map reorderRhyme) . map orderByRhyme . groupLines
            reorderRhyme = id -- not implemented
            reorderGroup = id -- not implemented
            concatGroups acc [] = acc
            concatGroups acc (group:[]) = acc ++ (group >>= (\ (a, b) -> [a, b]))
            concatGroups acc (group1:group2:rest) = concatGroups (acc ++ (zip group1 group2 >>= (\ ((a, b), (c, d)) -> [a, c, b, d]))) rest
 
    main =
        hSetEncoding stdin utf8 >> hSetEncoding stdout utf8 >> getContents >>= mapM putStrLn . solve
 
-- BestMatching.hs
module BestMatching (findBestMatching) where
 
    data NetworkEdge = NetworkEdge { from :: Int, to :: Int, cost :: Int, capacity :: Int, flow :: Int }
        deriving (Show)
 
    infinity = 100000
 
    initNetwork distance xs ys partSize source sink part1Offset part2Offset =
        [0..partSize - 1] >>= (\ v -> [NetworkEdge source (part1Offset + v) 0 1 0, NetworkEdge (part2Offset + v) sink 0 1 0]
            ++ [NetworkEdge (part1Offset + v) (part2Offset + v') (distance (xs !! v) (ys !! v')) 1 0 | v' <- [0..partSize - 1]])
            >>= (\ e@(NetworkEdge x y d _ _) -> [e, NetworkEdge y x (-d) 0 0])
 
    maxExtraFlowOnPath result path i network
        | path !! i == -1 = result
        | otherwise = maxExtraFlowOnPath (min result $ capacity edge - flow edge) path (from edge) network
            where edge = network !! (path !! i)
 
    addFlowOnPath extraFlow path i network
        | path !! i == -1 = network
        | (path !! i) `mod` 2 == 0 = 
            let (x, y:y':ys) = splitAt (path !! i) network in
            addFlowOnPath extraFlow path (from y) $ x ++ ((y { flow = flow y + extraFlow }):(y' { flow = flow y' - extraFlow }):ys)
        | otherwise =
            let (x, y':y:ys) = splitAt (path !! i - 1) network in
            addFlowOnPath extraFlow path (from y) $ x ++ (y' { flow = flow y' - extraFlow }):((y { flow = flow y + extraFlow }):ys)
 
    addExtraFlowOnPath path i network = addFlowOnPath (maxExtraFlowOnPath infinity path i network) path i network
 
    findShortestPathInResidualNetwork networkSize = findShortestPathInResidualNetwork' networkSize ([-1,-1..], 0:[infinity, infinity..]) networkSize
        where
            findShortestPathInResidualNetwork' 0 acc _ _ to _ = ((fst acc) !! to /= -1, take networkSize $ fst acc)
            findShortestPathInResidualNetwork' iteration acc networkSize from to network =
                findShortestPathInResidualNetwork' (iteration - 1) (foldl relax acc $ zip [0..] network) networkSize from to network
            relax acc@(result, distances) (i, edge)
                | flow edge >= capacity edge || distances !! (from edge) >= infinity || distances !! (to edge) <= (distances !! (from edge)) + cost edge = acc
                | otherwise =
                    let (resPrev, res:resRest) = splitAt (to edge) result in
                    let (distPrev, dist:distRest) = splitAt (to edge) distances in
                    (resPrev ++ (i:resRest), distPrev ++ ((distances !! (from edge)) + (cost edge):distRest))
 
    findBestMatching distance xs ys
        | length xs /= length ys = error "Lengths should be equal"
        | otherwise = restoreAnswer $ addFlowWhilePossible True [-1, -1..] $ initNetwork distance xs ys partSize source sink part1Offset part2Offset
            where
                partSize = length xs
                source = 0
                sink = 1 + partSize * 2
                part1Offset = 1
                part2Offset = 1 + partSize
                networkSize = 2 + partSize * 2
                addFlowWhilePossible False _ network = network
                addFlowWhilePossible True path network =
                    let (hasPath, nextPath) = findShortestPathInResidualNetwork networkSize source sink network in
                    addFlowWhilePossible hasPath nextPath $ addExtraFlowOnPath path sink network
                restoreAnswer network = filter (\ (NetworkEdge f t _ _ fl) -> fl == 1 && f >= part1Offset && f < part1Offset + partSize && t >= part2Offset && t < part2Offset + partSize && f < t) network
                    >>= (\ (NetworkEdge f t _ _ _) -> [(xs !! (f - part1Offset), ys !! (t - part2Offset))])