{-
  Sudoku solver, using simple constraint propagation to 
  limit search, by determining singleton numbers and positions;
  a puzzle is represented as a list of lines, where each line
  is a list of positions (line,column,block) paired with the
  range of numbers possible on that position.

  claus reinke
  march/april 2006
-}
module Main where

import List
import Data.Char
import Control.Monad(when,guard)
import Control.Monad.Error

-------------------------- puzzle input/output

-- convert Char to range of possible numbers per position
c2r ' ' = [1..9]
c2r c   = [read [c]]

-- convert range to number if singleton, to nothing if fuzzy 
r2c [n] = head (show n)
r2c _   = ' '

-- basic read/write
readPuzzle :: [String] -> [[((Int,Int,Int),[Int])]]
readPuzzle s = [ [ ((i,j,blockNum i j),c2r char) 
                 | (j,char) <- zip [1..9] line ] 
               | (i,line) <- zip [1..9] s ]

blockNum i j = ((i-1)`div`3)*3+((j-1)`div`3)+1

writePuzzle m = unlines [ map r2c line | line <- m ]

-- add separators for readability
add sep s@[]           = [sep]
add sep s@(h1:h2:h3:t) = sep:h1:h2:h3:add sep t 

writeLinedPuzzle m = unlines $ 
  add "+---+---+---+" [ add '|' $ [ r2c r | (pos,r) <- line] | line <- m ]

-- output range info, too

-- display unique numbers as well as fuzzy numbers on position
flagRange r = [ flag i r | i <- [1..9] ]
flag i c | i `elem` c  = head (show i)
         | length c==1 = ' '
         | otherwise   = '-'

writeFuzzyPuzzle p = unlines $ 
  add (concat (replicate 3 "++==========+=========+=========")++"++") $
  [ concat $ add "||" [' ': flagRange r | (pos,r) <- l ] | l <- p ]

-------------------------- are we there yet?

checkSolvedPuzzle fp = 
     ((and (map (all singleton) fp))            `orElse` "undetermined positions!")
  >> ((and [sort l==[1..9] | l<-getLines fp])   `orElse` "inconsistent lines!")
  >> ((and [sort c==[1..9] | c<-getColumns fp]) `orElse` "inconsistent columns!")
  >> ((and [sort b==[1..9] | b<-getBlocks fp])  `orElse` "inconsistent blocks!")
  where c `orElse` msg = if c then Right True else Left msg

singleton (pos,l) = length l==1

getLines   fp = [[ n | (pos,[n]) <- l ] | l <- fp] 
getColumns fp = [[ n | (pos,[n]) <- c ] | c <- transpose fp] 
getBlocks  fp = [[ n | ((i,j,k'),[n]) <- concat fp, k'==k ] | k<-[1..9] ]

-------------------------- propagators

-- commit to number, eliminating it from other ranges in same line/column/block
set ((line,col,block),n) p = 
  assertP (all ((==9).length)) $
  [ [ (pos,nr) | (pos,c) <- l, nr <- narrow pos c ] | l <- p ]
  where
    narrow (i,j,k) range 
      | (i,j)==(line,col)             = assertC (n `elem` range) [n]
      | i==line || j==col || k==block = assertP (not . null) $ filter (/=n) range
      | otherwise                     = assertP (not . null) range

assertC c x = [ x | c ]
assertP p x = [ x | p x ]

-- check for uniquely determined numbers/positions, commit and propagate
propagate p = setSingletons (findSingletonRanges ++. findSingletonPos) p

setSingletons findSingletons p = return $ while p (findSingletons p)
  where
    while p s = if p==np then p else while np (findSingletons np)
      where np = foldr setAndCheck p s
            setAndCheck s p = check (set s p)
            check [p]       = p
            check []        = []

infixl ++.
(a ++. b) p = nub (a p ++ b p)

-- positions that can only hold a single number
findSingletonRanges p = concat $ 
  [[ (pos,c) | (pos,[c]) <- l ] | l <- p ]

-- numbers that can only be in a single position
findSingletonPos p = singles byLine++singles byCol++singles byBlock
  where
    singles byCoord = [ (pos,n)
                      | coord <- [1..9 ], n <- [1..9] 
                      , [(pos,r)] <- [filter (byCoord n coord) (concat p)] 
                      ] 
    byLine  n l ((l1,_,_),r) = l==l1 && n `elem` r
    byCol   n c ((_,c1,_),r) = c==c1 && n `elem` r
    byBlock n b ((_,_,b1),r) = b==b1 && n `elem` r

-------------------------- guessing, with propagation

guesses p = loop [] p
  where loop gs p = do
          (c,p) <- candidates p
          return (c:gs,p) ++ loop (c:gs) p

candidates p  = do
  (pos,c,p) <- candidate p -- possible candidate
  p <- set (pos,c) p       -- commit, and narrow ranges 
  p <- propagate p         -- iterate propagation of singletons
  return ((pos,c), p)      -- return only locally consistent candidates

-- every range element is a candidate, but consider each one only once
candidate p = sift [ (pos,c,p) | (pos,r) <- concat p, length r > 1, c <- r ]
  where sift []            = []
        sift ((pos,c,p):t) = (pos,c,p):map (\(pos',c',p')->(pos',c',delete (pos,c) p')) (sift t)
        delete (pos,c) p   = (map . map) (\(ijk,r)->if ijk==pos
                                                    then (ijk,filter (/=c) r)
                                                    else (ijk,r) ) p 

-------------------------- let's try it..

main = mapM_ test [s1,s2,s3,s4,s5]
-- main = test s0

test s = do
  let f1   = readPuzzle s
      [f2] = propagate f1
  putStrLn $ "input\n"++writeFuzzyPuzzle f1
  putStrLn $ "after initial propagation\n"++writeFuzzyPuzzle f2
  ifE (checkSolvedPuzzle f2)
    (putStrLn $ "done!\n"++writeLinedPuzzle f2) 
    (\m->do putStrLn $ m++"\n\nresorting to guesswork"
            mapM_ checkGuess $ guesses f2) 

checkGuess (cs,g) = ifE (checkSolvedPuzzle g)  
                      (putStrLn $ "\nfound solution! guesses: "++show cs++"\n"
                                  ++writeLinedPuzzle g)
                      (const $ return ()) -- (putStrLn) 

ifE c r l = either l (const r) c

-------------------------- some test cases

-- from Michael Hanus' Curry solver
s1 = ["9  2  5  ",
      " 4  6  3 ",
      "  3     6",
      "   9  2  ",
      "    5  8 ",
      "  7  4  3",
      "7     1  ",
      " 5  2  4 ",
      "  1  6  9"]

s2 = ["819  5   ",
      "  2   75 ",
      " 371 4 6 ",
      "4  59 1  ",
      "7  3 8  2",
      "  3 62  7",
      " 5 7 921 ",
      " 64   9  ",
      "   2  438"]

-- from the  Haskell wiki sudoku page:

s3 = [" 5  6   1"
     ,"  48   7 "
     ,"8      52"
     ,"2   57 3 "
     ,"         "
     ," 3 69   5"
     ,"79      8"
     ," 1   65  "
     ,"5   3  6 "
     ]

-- a mild one from The Times:

s4 = ["7   6   2"
     ,"   7 2   "
     ," 369 451 "
     ,"87     95"
     ,"  1   3  "
     ,"69     21"
     ," 281 597 "
     ,"   8 3   "
     ,"5   7   3"
     ]

-- and a fiendish one from The Times:

s5 = ["    23  7"
     ,"6  8 4 2 "
     ,"   7   31"
     ,"5      7 "
     ," 9     4 "
     ," 2      9"
     ,"13   9   "
     ," 5 3 2  8"
     ,"4  16    "
     ]

-- last, but not least, the extreme test of no info at all:

s0 = ["         "
     ,"         "
     ,"         "
     ,"         "
     ,"         "
     ,"         "
     ,"         "
     ,"         "
     ,"         "
     ]