-- http://p...content-available-to-author-only...h.net/test/read.cgi/tech/1226229627/317
import Control.Applicative
import Data.Monoid
import Data.Array (Array,array,assocs,(//),(!))
import Data.Maybe (isJust)
import Data.List (find,sortBy,transpose,(\\))
import Data.Ord (comparing)
import Debug.Trace

type Loc = (Int, Int)
type Mesh = Array Loc (Maybe Int)
type Block = (Sum Int, [Loc])

ans :: [Int]
ans = [1..6]

locations :: [Loc]
locations = (,) <$> ans <*> ans

blocks :: [Block]
blocks = [
    (Sum  3, [(1,1),(1,2)])
  , (Sum  4, [(2,1)])
  , (Sum 13, [(3,1),(3,2),(3,3)])
  , (Sum  5, [(4,1),(5,1)])
  , (Sum  8, [(6,1),(6,2)])
  , (Sum  7, [(2,2),(2,3)])
  , (Sum  1, [(4,2)])
  , (Sum  7, [(5,2),(5,3)])
  , (Sum 11, [(1,3),(1,4)])
  , (Sum  7, [(4,3),(4,4)])
  , (Sum  6, [(6,3)])
  , (Sum  6, [(2,4),(3,4)])
  , (Sum  6, [(5,4),(6,4)])
  , (Sum  9, [(1,5),(2,5)])
  , (Sum  6, [(3,5),(4,5)])
  , (Sum  4, [(5,5)])
  , (Sum  3, [(6,5),(6,6)])
  , (Sum  4, [(1,6)])
  , (Sum  5, [(2,6),(3,6)])
  , (Sum 11, [(4,6),(5,6)])
  ]
main :: IO ()
main = case solve new_mesh of
    Nothing -> print "can't solve it."
    Just m -> mapM_ print $ showMesh m
  where new_mesh = array((1,1),(6,6)) [(l, Nothing) | l <- locations]

solve :: Mesh -> Maybe Mesh
solve m
  | completed m = Just m
  | otherwise = find completed [s | Just s <- spread]
  where
    completed = (all $ isJust . snd) . assocs
    emp_locs = [l | (l, Nothing) <- assocs m]
    easy_to_head = sortBy . comparing $ length . snd
    filling = easy_to_head $ zip emp_locs $ map (candidates m) emp_locs
    spread = spread' -- `debugMesh` m                                                                                                                                                 
    spread' = map solve [m // [(loc, Just x)] | (loc, xs) <- filling, x <- xs]

candidates :: Mesh -> Loc -> [Int]
candidates m loc@(x,y) = let
    block = [b | b@(_, ls) <- blocks, loc `elem` ls]
    block_avails = concat $ map (blockCandidates m) block
    row_constraint = fixedVals m $ (,) <$> [x] <*> ans
    col_constraint = fixedVals m $ (,) <$> ans <*> [y]
    ret = block_avails \\ (row_constraint ++ col_constraint)
  in ret -- `debug` (loc,block_avails,"row",row_constraint,"col",col_constraint,ret)                                                                                                  

blockCandidates :: Mesh -> Block -> [Int]
blockCandidates m (Sum s, ls) = let
    rest_num = length ls - (length $ fixedVals m ls)
    rest_sum = s - (sum $ fixedVals m ls)
    ret = concat $ filter (\ xs -> sum xs == rest_sum) $ combinations rest_num ans
  in ret -- `debug` ((Sum s,ls),"fixed",fixedVals m ls,"rest_num",rest_num,"rest_sum",rest_sum,ret)                                                                                   

fixedVals :: Mesh -> [Loc] -> [Int]
fixedVals m ls = [ n | Just n <- [m ! l | l <- ls]]

combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations _ [] = []
combinations n xs@(y:ys)
  | n < 0 = []
  | otherwise = case drop (n-1) xs of
    [] -> []
    [_] -> [xs]
    _ -> [y:c | c <- combinations (n-1) ys] ++ combinations n ys

splitEvery :: Int -> [a] -> [[a]]
splitEvery _ [] = []
splitEvery n list = first : (splitEvery n rest)  where (first,rest) = splitAt n list

showMesh :: Mesh -> [[String]]
showMesh m = transpose $ splitEvery 6 [maybe " " show x | (_, x) <- assocs m]

debugMesh :: a -> Mesh -> a
debugMesh f m = foldr traceShow (trace "----" f) $ showMesh m

debug :: Show a => c -> a -> c
debug = flip traceShow