-- 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))])