fork download 
  1. import Control.Applicative
  2. import Data.Array (Array,array,assocs,(//),(!))
  3. import Data.Maybe (isJust,listToMaybe)
  4. import Data.List (sortBy,transpose,nub,(\\))
  5. import Data.Ord (comparing)
  6. import Debug.Trace
  7.  
  8. type Loc = (Int, Int)
  9. type Mesh = Array Loc (Maybe Int)
  10.  
  11. ans :: [Int]
  12. ans = [1..9]
  13.  
  14. block_side :: Int
  15. block_side = 3
  16.  
  17. paper :: Mesh
  18. paper = array ((1,1),(length ans,length ans)) [(l, Nothing) | l <- (,) <$> ans <*> ans]
  19.  
  20. main :: IO ()
  21. main = case solve problem of
  22.     Nothing -> print "can't solve it."
  23.     Just m -> mapM_ print $ showMesh m
  24.   where
  25.     problem = paper // [
  26.         ((1, 2), Just 5), ((1, 4), Just 7), ((1, 9), Just 1)
  27.       , ((2, 4), Just 3), ((2, 5), Just 2)
  28.       , ((3, 2), Just 8), ((3, 4), Just 6), ((3, 5), Just 9), ((3, 9), Just 4)
  29.       , ((4, 1), Just 2), ((4, 3), Just 9), ((4, 5), Just 1), ((4, 7), Just 3)
  30.       , ((5, 2), Just 6), ((5, 3), Just 3), ((5, 7), Just 1), ((5, 8), Just 4)
  31.       , ((6, 3), Just 7), ((6, 5), Just 5), ((6, 7), Just 6), ((6, 9), Just 2)
  32.       , ((7, 1), Just 1), ((7, 5), Just 3), ((7, 6), Just 9), ((7, 8), Just 7)
  33.       , ((8, 5), Just 6), ((8, 6), Just 4)
  34.       , ((9, 1), Just 4), ((9, 6), Just 7), ((9, 8), Just 2)
  35.       ]
  36.  
  37. solve :: Mesh -> Maybe Mesh
  38. solve m
  39.   | completed m = Just m
  40.   | otherwise = listToMaybe [s | Just s <- map solve progress]
  41.   where
  42.     completed = (all $ isJust . snd) . assocs
  43.     empties = [l | (l, Nothing) <- assocs m]
  44.     easy_to_head = sortBy . comparing $ length . snd
  45.     filling = easy_to_head $ zip empties $ map (candidates m) empties
  46.     progress = progress' -- `debugMesh` m
  47.     progress' = [m // [(loc, Just x)] | (loc, xs) <- filling, x <- xs]
  48.  
  49. candidates :: Mesh -> Loc -> [Int]
  50. candidates m (x,y) = let
  51.     block_range l = map (+ 3 * div (l - 1) block_side) [1 .. block_side]
  52.     block = (,) <$> block_range x <*> block_range y
  53.     row = (,) <$> [x] <*> ans
  54.     col = (,) <$> ans <*> [y]
  55.     fixedVals ls = [ n | Just n <- [m ! l | l <- ls]]
  56.     constraint = fixedVals . nub $ block ++ row ++ col
  57.   in ans \\ constraint
  58.  
  59. chunk :: Int -> [a] -> [[a]]
  60. chunk _ [] = []
  61. chunk n list = first : (chunk n rest)  where (first,rest) = splitAt n list
  62.  
  63. showMesh :: Mesh -> [[String]]
  64. showMesh m = transpose $ chunk (length ans) [maybe " " show x | (_, x) <- assocs m]
  65.  
  66. debugMesh :: a -> Mesh -> a
  67. debugMesh f m = foldr traceShow (trace "----" f) $ showMesh m
  68.  
  69. debug :: Show a => c -> a -> c
  70. debug = flip traceShow
  71.  
Success #stdin #stdout 0.03s 6292KB
comments (?)
stdin 
Standard input is empty
stdout 
["3","6","7","2","5","8","1","9","4"]
["5","9","8","4","6","1","2","7","3"]
["2","4","1","9","3","7","8","5","6"]
["7","3","6","8","9","4","5","2","1"]
["4","2","9","1","7","5","3","6","8"]
["8","1","5","6","2","3","9","4","7"]
["9","7","2","3","1","6","4","8","5"]
["6","8","3","5","4","9","7","1","2"]
["1","5","4","7","8","2","6","3","9"]
https://ideone.com/GFENZj
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!