import Control.Applicative
import Control.Monad
import qualified Data.List as L

replace :: Eq a => a -> a -> [a] -> [a]
replace from to = map f
    where f x | x == from = to
              | otherwise = x

blank :: Char
blank = '□'

insertWord :: String -> Int -> Int -> [[String]]
insertWord word i j = xs : [L.transpose xs]
    where
      xs = replicate j (replicate (length word + i) blank) ++ [replicate i blank ++ word]

blankMatrix :: (Int, Int) -> [String]
blankMatrix (i, j) = [[blank | _ <- [1..j]] | _ <- [1..i]]

infixr 2 .||
(.||) :: [String] -> [String] -> [String]
xss1 .|| yss1 = maybe [] id $ f xss1 yss1
    where
      f :: [String] -> [String] -> Maybe [String]
      f (xs:xss) (ys:yss) = (:) <$> g xs ys <*> f xss yss
      f (xs:xss) _        = (:) <$> g xs [] <*> f xss []
      f _        (ys:yss) = (:) <$> g [] ys <*> f [] yss
      f _         _       = Just []
      g :: String -> String -> Maybe String
      g (x:xs) (y:ys) | x == blank = (y:) <$> g xs ys
                      | y == blank = (x:) <$> g xs ys
                      | x == y     = (x:) <$> g xs ys
                      | otherwise  = Nothing
      g (x:xs) _      = (x:) <$> g xs []
      g _      (y:ys) = (y:) <$> g [] ys
      g _      _      = Just []

listup :: [String] -> [[String]]
listup xs = foldM f [] xs
    where
      f a x = (a .||) <$> concat [insertWord x i j | i <- [0..len], j <- [0..len]]
      len = sum (map length xs) - (length xs - 1) - 1

isCrossWord :: [String] -> [String] -> Bool
isCrossWord wordList matrix = L.sort wordList == L.sort pzWords && checkLen
    where
      pzWords = filter ((>1) . length) . concatMap (words . replace blank ' ') $ matrix ++ xst
      xst = L.transpose matrix
      checkLen = (sum $ map length wordList) - (length wordList - 1) == (sum . map sumc $ matrix)
      sumc xs = foldr (\x a -> if x == blank then a else a + 1) 0 xs

getWH :: [String] -> (Int, Int)
getWH xss = (length xss, maximum $ map length xss)

findCrossWord :: [String] -> Maybe [String]
findCrossWord wordList =
    liftA2 (.||) id (blankMatrix . getWH) <$> L.find (isCrossWord wordList) (listup wordList)

main :: IO ()
main = do
    forM_ [ ["スイカ", "カイバ", "イヌ"], ["マンガ", "バター"] ] $
        putStrLn . maybe "not found." unlines . findCrossWord