import Data.Array
import Data.List (sort)


getWord :: String -> (Int, String)
getWord ('-':cs) = (l+1, remainingCS)
 where (l, remainingCS) = getWord cs
getWord (_:cs) = (1, cs)
getWord "" = (1, "")

wordsInLine :: Int -> String -> [(Int, Int)]
wordsInLine _ "" = []
wordsInLine pos ('+':cs) = wordsInLine (pos+1) cs
wordsInLine pos ('-':cs) = if firstWordLength > 1 then (pos, firstWordLength):otherWords else otherWords
 where (firstWordLength, remainingCS) = getWord cs
       otherWords = wordsInLine (pos+firstWordLength+1) remainingCS

addY :: Int -> (Int, Int) -> (Int, Int, Int)
addY y (x, l) = (x, y, l)

wordsInLineWithY :: Int -> String -> [(Int, Int, Int)]
wordsInLineWithY y line = map (addY y) (wordsInLine 0 line)

addX :: Int -> (Int, Int) -> (Int, Int, Int)
addX x (y, l) = (x, y, l)

wordsInLineWithX :: Int -> String -> [(Int, Int, Int)]
wordsInLineWithX x line = map (addX x) (wordsInLine 0 line)

horizontalWords :: Int -> [String] -> [(Int, Int, Int)]
horizontalWords _ [] = []
horizontalWords y (line:lines) = (wordsInLineWithY y line) ++ (horizontalWords (y+1) lines)

verticalWords :: Int -> [String] -> [(Int, Int, Int)]
verticalWords _ ([]:_) = []
verticalWords x linesIn = (wordsInLineWithX x line) ++ (verticalWords (x+1) lines)
 where line = map head linesIn
       lines = map tail linesIn


letterLocations :: (Int,Int) -> Int -> Int -> Int -> [Int]
letterLocations dir x y 0 = []
letterLocations dir@(dirX,dirY) x y l = (y*10+x):(letterLocations dir (x+dirX) (y+dirY) (l-1))

allLetterLocations :: (Int,Int) -> Int -> [(Int, Int, Int)] -> [(Int, (Int, Int))]
allLetterLocations _ _ [] = []
allLetterLocations dir i ((x,y,l):ws) = wordLocsWithWordIndex ++ (allLetterLocations dir (i+1) ws)
 where wordLocs = zip (letterLocations dir x y l) [0..]
       f (arrayI, pos) = (arrayI, (i, pos))
       wordLocsWithWordIndex = map f wordLocs

mixInEmpty :: Int -> Int -> [(Int, (Int, Int))] -> [(Int, (Int, Int))]
mixInEmpty i endI _ | i == endI = []
mixInEmpty i endI [] = (i,((-1),0)):(mixInEmpty (i+1) endI [])
mixInEmpty i endI allE@((k,v):es) | k == i = (k,v):(mixInEmpty (i+1) endI es)
                             | otherwise = (i,((-1),0)):(mixInEmpty (i+1) endI allE)

intersectLookup :: [(Int, Int, Int)] -> Array Int (Int, Int)
intersectLookup words = array (0,99) (mixInEmpty 0 100 (allLetterLocations (1,0) 0 words))

addToFront :: [a] -> Int -> a -> [a]
addToFront l 0 _ = l
addToFront l n e = e:(addToFront l (n-1) e)

refsForWord :: Array Int (Int, Int) -> Int -> [Int] -> [(Int, Int, Int)]
refsForWord _ _ [] = []
refsForWord lookup i (arrayI:vs) = if w == (-1) then rest else (i,w,c):rest
 where (w, c) = lookup!arrayI
       rest = refsForWord lookup (i+1) vs

refs :: Array Int (Int, Int) -> [(Int, Int, Int)] -> [[(Int, Int, Int)]]
refs _ [] = []
refs lookup ((x,y,l):vs) = lookupForThis:lookupForRest
 where locs = letterLocations (0,1) x y l
       lookupForThis = refsForWord lookup 0 locs
       lookupForRest = refs lookup vs

getIntersects :: [(Int, Int, Int)] -> [(Int, Int, Int)] -> [[(Int, Int, Int)]]
getIntersects hs vs = addToFront vrefs (length hs) []
 where lookup = intersectLookup hs
       vrefs = refs lookup vs


intersectsOK :: [(Int, Int, Int)] -> String -> [String] -> Bool
intersectsOK [] _ _ = True
intersectsOK ((charInThis,wordRef,charInWord):intersects) word resultSoFar =
    if resultSoFar!!wordRef!!charInWord  == word!!charInThis
    then intersectsOK intersects word resultSoFar
    else False

wordPossibilities :: Int -> [(Int, Int, Int)] -> [String] -> [String] -> [String] -> [([String], String)]
wordPossibilities _ _ [] _ _ = []
wordPossibilities l intersects (word:wordsLeft) otherWordsLeft resultSoFar =
        if length(word) == l && intersectsOK intersects word resultSoFar
        then (otherWordsLeft++wordsLeft,word):otherPossibilities
        else otherPossibilities
 where otherPossibilities = wordPossibilities l intersects wordsLeft (word:otherWordsLeft) resultSoFar

firstSolution :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [([String], String)] -> [String]
firstSolution _ _ _ [] = []
firstSolution ls intersects resultSoFar ((wordsLeft,word):ps) =
  if solution == [] then firstSolution ls intersects resultSoFar ps else solution
 where solution = solve' ls intersects wordsLeft (resultSoFar++[word])

solve' :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [String] -> [String]
solve' [] _ _ resultSoFar = resultSoFar
solve' (l:ls) (intersect:intersects) words resultSoFar =
  firstSolution ls intersects resultSoFar ps
 where ps = wordPossibilities l intersect words [] resultSoFar

solve :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [String]
solve wordLengths intersects words = solve' wordLengths intersects words []



renderChars :: [(Int,Int)] -> [(Int, Int, Int)] -> [String] -> [(Int, Char)]
renderChars _ [] _ = []
renderChars (dir:dirs) ((x,y,l):spaces) (word:words) = forWord ++ rest
 where locs = letterLocations dir x y l
       forWord = zip locs word
       rest = renderChars dirs spaces words

renderLine :: Int -> Int -> [(Int, Char)] -> String
renderLine i endI cs | i == endI = ""
renderLine i endI [] = '+':(renderLine (i+1) endI [])
renderLine i endI allCS@((ci,c):cs) | ci < i = renderLine i endI cs
                                    | ci == i = c:(renderLine (i+1) endI cs)
                                    | otherwise = '+':(renderLine (i+1) endI allCS)

renderLines :: Int -> [(Int, Char)] -> [String]
renderLines 100 _ = []
renderLines startI cs = (renderLine startI endI cs):(renderLines endI cs)
 where endI = startI + 10

render :: [(Int,Int)] -> [(Int, Int, Int)] -> [String] -> [String]
render dirs spaces words = renderLines 0 cs
 where cs = sort $ renderChars dirs spaces words

wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s =  case dropWhile p s of
                      "" -> []
                      s' -> w : wordsWhen p s''
                            where (w, s'') = break p s'

doit strIn = unlines resultLines
 where ls = lines strIn
       templateLines = take 10 ls
       [wordsToFitLine] = drop 10 ls
       wordsToFit = wordsWhen (==';') wordsToFitLine
       hs = horizontalWords 0 templateLines
       vs = verticalWords 0 templateLines
       intersects = getIntersects hs vs
       extractL (_,_,l) = l
       lengths = (map extractL hs) ++ (map extractL vs)
       solution = solve lengths intersects wordsToFit
       takeN n a = take n $ repeat a
       dirs = (takeN (length hs) (1,0)) ++ (takeN (length vs) (0,1))
       resultLines = render dirs (hs++vs) solution

main = interact doit