fork download 
  1. -- http://p...content-available-to-author-only...h.net/test/read.cgi/tech/1226229627/317
  2. import Control.Applicative
  3. import Data.Monoid
  4. import Data.Array (Array,array,assocs,(//),(!))
  5. import Data.Maybe (isJust)
  6. import Data.List (find,sortBy,transpose,(\\))
  7. import Data.Ord (comparing)
  8. import Debug.Trace
  9.  
  10. type Loc = (Int, Int)
  11. type Mesh = Array Loc (Maybe Int)
  12. type Block = (Sum Int, [Loc])
  13.  
  14. ans :: [Int]
  15. ans = [1..6]
  16.  
  17. locations :: [Loc]
  18. locations = (,) <$> ans <*> ans
  19.  
  20. blocks :: [Block]
  21. blocks = [
  22.     (Sum  3, [(1,1),(1,2)])
  23.   , (Sum  4, [(2,1)])
  24.   , (Sum 13, [(3,1),(3,2),(3,3)])
  25.   , (Sum  5, [(4,1),(5,1)])
  26.   , (Sum  8, [(6,1),(6,2)])
  27.   , (Sum  7, [(2,2),(2,3)])
  28.   , (Sum  1, [(4,2)])
  29.   , (Sum  7, [(5,2),(5,3)])
  30.   , (Sum 11, [(1,3),(1,4)])
  31.   , (Sum  7, [(4,3),(4,4)])
  32.   , (Sum  6, [(6,3)])
  33.   , (Sum  6, [(2,4),(3,4)])
  34.   , (Sum  6, [(5,4),(6,4)])
  35.   , (Sum  9, [(1,5),(2,5)])
  36.   , (Sum  6, [(3,5),(4,5)])
  37.   , (Sum  4, [(5,5)])
  38.   , (Sum  3, [(6,5),(6,6)])
  39.   , (Sum  4, [(1,6)])
  40.   , (Sum  5, [(2,6),(3,6)])
  41.   , (Sum 11, [(4,6),(5,6)])
  42.   ]
  43. main :: IO ()
  44. main = case solve new_mesh of
  45.     Nothing -> print "can't solve it."
  46.     Just m -> mapM_ print $ showMesh m
  47.   where new_mesh = array((1,1),(6,6)) [(l, Nothing) | l <- locations]
  48.  
  49. solve :: Mesh -> Maybe Mesh
  50. solve m
  51.   | completed m = Just m
  52.   | otherwise = find completed [s | Just s <- spread]
  53.   where
  54.     completed = (all $ isJust . snd) . assocs
  55.     emp_locs = [l | (l, Nothing) <- assocs m]
  56.     easy_to_head = sortBy . comparing $ length . snd
  57.     filling = easy_to_head $ zip emp_locs $ map (candidates m) emp_locs
  58.     spread = spread' -- `debugMesh` m                                                                                                                                                 
  59.     spread' = map solve [m // [(loc, Just x)] | (loc, xs) <- filling, x <- xs]
  60.  
  61. candidates :: Mesh -> Loc -> [Int]
  62. candidates m loc@(x,y) = let
  63.     block = [b | b@(_, ls) <- blocks, loc `elem` ls]
  64.     block_avails = concat $ map (blockCandidates m) block
  65.     row_constraint = fixedVals m $ (,) <$> [x] <*> ans
  66.     col_constraint = fixedVals m $ (,) <$> ans <*> [y]
  67.     ret = block_avails \\ (row_constraint ++ col_constraint)
  68.   in ret -- `debug` (loc,block_avails,"row",row_constraint,"col",col_constraint,ret)                                                                                                  
  69.  
  70. blockCandidates :: Mesh -> Block -> [Int]
  71. blockCandidates m (Sum s, ls) = let
  72.     rest_num = length ls - (length $ fixedVals m ls)
  73.     rest_sum = s - (sum $ fixedVals m ls)
  74.     ret = concat $ filter (\ xs -> sum xs == rest_sum) $ combinations rest_num ans
  75.   in ret -- `debug` ((Sum s,ls),"fixed",fixedVals m ls,"rest_num",rest_num,"rest_sum",rest_sum,ret)                                                                                   
  76.  
  77. fixedVals :: Mesh -> [Loc] -> [Int]
  78. fixedVals m ls = [ n | Just n <- [m ! l | l <- ls]]
  79.  
  80. combinations :: Int -> [a] -> [[a]]
  81. combinations 0 _ = [[]]
  82. combinations _ [] = []
  83. combinations n xs@(y:ys)
  84.   | n < 0 = []
  85.   | otherwise = case drop (n-1) xs of
  86.     [] -> []
  87.     [_] -> [xs]
  88.     _ -> [y:c | c <- combinations (n-1) ys] ++ combinations n ys
  89.  
  90. splitEvery :: Int -> [a] -> [[a]]
  91. splitEvery _ [] = []
  92. splitEvery n list = first : (splitEvery n rest)  where (first,rest) = splitAt n list
  93.  
  94. showMesh :: Mesh -> [[String]]
  95. showMesh m = transpose $ splitEvery 6 [maybe " " show x | (_, x) <- assocs m]
  96.  
  97. debugMesh :: a -> Mesh -> a
  98. debugMesh f m = foldr traceShow (trace "----" f) $ showMesh m
  99.  
  100. debug :: Show a => c -> a -> c
  101. debug = flip traceShow
Success #stdin #stdout 0.01s 6292KB
comments (?)
stdin 
Standard input is empty
stdout 
["1","4","6","2","3","5"]
["2","5","4","1","6","3"]
["5","2","3","4","1","6"]
["6","1","5","3","2","4"]
["3","6","1","5","4","2"]
["4","3","2","6","5","1"]
https://ideone.com/dzcX1B
language:
Haskell (ghc 8.4.4)
created:
9 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!