http://pastebin.com/f41c6cbf8

import Data.List

indexOf :: (Eq a) => [a] -> a -> Int
indexOf xs x = head $ elemIndices x xs

nextTo :: Int -> Int -> Bool
nextTo a b = abs (a - b) == 1

rightOf :: Int -> Int -> Bool
rightOf a b = a == b + 1

options :: String -> [[String]]
options = permutations . words

solution :: [[String]]
solution = head [transpose [cs, os, ds, ss, ps] |
    cs <- options "red green ivory yellow blue",
    let color = indexOf cs,
    color "green" `rightOf` color "ivory",
    os <- options "english spaniard ukranian norwegian japanese",
    let owner = indexOf os,
    owner "norwegian" == 0,
    owner "english" == color "red",
    owner "norwegian" `nextTo` color "blue",
    ds <- options "coffee tea milk juice water",
    let drinks = indexOf ds,
    drinks "milk" == 2,
    drinks "coffee" == color "green",
    owner "ukranian" == drinks "tea",
    ss <- options "old_gold kools chesterfields parliaments lucky_strike",
    let smokes = indexOf ss,
    smokes "kools" == color "yellow",
    smokes "lucky_strike" == drinks "juice",
    owner "japanese" == smokes "parliaments",
    ps <- options "dog snails fox horse zebra",
    let pet = indexOf ps,
    owner "spaniard" == pet "dog",
    smokes "old_gold" == pet "snails",
    smokes "chesterfields" `nextTo` pet "fox",
    smokes "kools" `nextTo` pet "horse"]

main :: IO ()
main = mapM_ print solution

import Data.List
import qualified Data.Map as M

type Grid = M.Map String (M.Map Int [String])

data Constraint = Link (String, String) (String, String)
                | PosLink (String, String) Int
                | NextTo (String, String) (String, String)
                | RightOf (String, String) (String, String)
                deriving Eq

type Solver = ([Constraint], Grid)

addConstraint :: Constraint -> Solver -> Solver
addConstraint c (cs, g) = (c : cs, g)

removeIf :: (String, String) -> (String, String) ->
    [String -> String -> Int -> Grid -> Bool] -> Grid -> Grid
removeIf (f1, v1) (f2, v2) cs g = M.adjust (M.mapWithKey (\k ->
    if and [c f1 v1 k g | c <- cs] then delete v2 else id)) f2 g

notAt :: (Int -> Int) -> String -> String -> Int -> Grid -> Bool
notAt f f1 v1 i g = M.notMember (f i) (g M.! f1) ||
                    notElem v1 (g M.! f1 M.! (f i))

runConstraint :: Constraint -> Grid -> Grid
runConstraint (Link a b) = removeIf a b conds . removeIf b a conds
    where conds = [(\f1 v1 k -> notElem v1 . (M.! k) . (M.! f1))]
runConstraint (PosLink (f1,v1) i) =
    M.adjust (M.update (const $ Just [v1]) i) f1
runConstraint (NextTo a b)  = removeIf a b [notAt pred, notAt succ]
runConstraint (RightOf a b) = removeIf a b [notAt pred] .
                              removeIf b a [notAt succ]

adjustOthers :: Eq k => (v -> v) -> k -> M.Map k v -> M.Map k v
adjustOthers f k = M.mapWithKey (\k' v -> if k' == k then v else f v)

simplify :: Grid -> Grid
simplify g = foldr ($) (M.mapWithKey (\_ v ->
    M.mapWithKey (\i x -> let d = x \\ concat (M.elems $ M.delete i v)
                          in if length d == 1 then d else x) v) g)
    [ M.adjust (adjustOthers (\\ take 1 x) i) f
    | (f, v) <- M.assocs g, (i, x) <- M.assocs v, length x == 1]

run :: Solver -> Solver
run (cs, g) = (cs, simplify $ foldr runConstraint g cs)

apply :: Solver -> Solver
apply = head . head . dropWhile (null . tail) . group . iterate run

solved :: M.Map k (M.Map k' [v]) -> Bool
solved g = and [False | (_, v)  <- M.assocs g,
                        (_, xs) <- M.assocs v, length xs /= 1]

solve :: Solver -> [String]
solve s = map (unwords . map head) . transpose . map (M.elems) .
          M.elems $ head [ r | let (cs, g) = apply s,
          (f, v) <- M.assocs $ g, (i, xs) <- M.assocs v, x <- xs,
          let (_, r) = apply (cs, M.adjust (M.adjust (const [x]) i) f g),
          solved r ]

grid :: Grid
grid = M.fromList . zip (words "owner brand drink pet color") $
    map (M.fromList . zip [1..] . replicate 5)
    [words "Englishman Ukranian Norwegian Japanese Spaniard",
     words "Old_Gold Kools Chesterfields Lucky_Strike Parliaments",
     words "Coffee Tea Milk Orange_Juice Water",
     words "Dog Snails Horse Fox Zebra",
     words "Red Green Ivory Yellow Blue"]

problem :: Solver
problem = foldr addConstraint ([], grid)
    [Link    ("owner", "Englishman")    ("color", "Red"),
     Link    ("owner", "Spaniard")      ("pet",   "Dog"),
     Link    ("drink", "Coffee")        ("color", "Green"),
     Link    ("owner", "Ukranian")      ("drink", "Tea"),
     RightOf ("color", "Ivory")         ("color", "Green"),
     Link    ("brand", "Old_Gold")      ("pet",   "Snails"),
     Link    ("brand", "Kools")         ("color", "Yellow"),
     PosLink ("drink", "Milk")          3,
     PosLink ("owner", "Norwegian")     1,
     NextTo  ("brand", "Chesterfields") ("pet",   "Fox"),
     NextTo  ("brand", "Kools")         ("pet",   "Horse"),
     Link    ("brand", "Lucky_Strike")  ("drink", "Orange_Juice"),
     Link    ("owner", "Japanese")      ("brand", "Parliaments"),
     NextTo  ("owner", "Norwegian")     ("color", "Blue")]

main :: IO ()
main = mapM_ putStrLn $ solve problem