1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:

module Sudoku where

import Data.Char (digitToInt)
import System.Environment (getArgs)

type Row a = [a]
type Column a = [a]
type Matrix a = [Row a]
type Digit = Int
type Grid = Matrix Digit
type CharGrid = Matrix Char

class Blank a where
   blank :: a->Bool

instance Blank Char where
    blank c = c == ' ' || c == '0'

instance Blank Int where
   blank n = n==0

digits = [1..9]

toDigits :: [Char] -> [Int]
toDigits [] = []
toDigits (c:cs) | blank c = 0 : toDigits cs
                | otherwise = digitToInt c : toDigits cs

toChars :: [Int] -> [Char]
toChars [] = []
toChars (x:xs) | x<0 || x >9 = error "number must be in the range 0 to 9"
               | blank x = '0' : toChars xs
               | otherwise = "0123456789" !! x : toChars xs

-- Die üblichen 9er-Zeilen; die Daten liegen in einem String vor, ohne Lösung. 
-- Format: ein String aus 81 Ziffern, 0 bis 9. Ungesetzte Felder sind 0 
stringToCharGrid :: String -> CharGrid
stringToCharGrid [] = []
stringToCharGrid s = (take 9 s) : stringToCharGrid (drop 9 s)

charGridToDigits :: CharGrid -> Grid
charGridToDigits [] = []
charGridToDigits (r:rs) = toDigits r : charGridToDigits rs

intGridToChars :: Grid -> CharGrid
intGridToChars [] = []
intGridToChars (r:rs) = toChars r : intGridToChars rs

nodups :: Eq a => [a] -> Bool
nodups [] = True
nodups [x] = True
nodups (x:xs) = all (/=x) xs && nodups xs

-- Liste muss sortiert sein
removeDups :: (Eq a) => [a] -> [a]
removeDups [] = []
removeDups [x] = [x]
removeDups (x:xs) | x == head xs = x: removeDups (tail xs)
                 | otherwise = x : removeDups xs

rows :: Matrix a -> Matrix a
rows = id

cols  :: Matrix a -> Matrix a
cols [] = []
cols [xs] = [[x] | x <- xs]
cols (xs:xss) = zipWith (:) xs (cols xss)

boxs :: Matrix a -> Matrix a
boxs = map ungroup . ungroup . map cols . group . map group

group :: [a] -> [[a]]
group [] = []
group xs = take 3 xs : group (drop 3 xs)

ungroup :: [[a]] -> [a]
ungroup = concat

pruneRow :: Row [Digit] -> Row [Digit]
pruneRow row = map (removeFixed fixed) row
                   where fixed = [d | [d] <- row]

removeFixed :: [Digit] -> [Digit] -> [Digit]
removeFixed ds [x] = [x] -- fixierte Zellen sollen erhalten bleiben
removeFixed ds xs = filter (`notElem` ds) xs --  alles aus xs entfernen, was in ds enthalten

{- die Funktion f kann eine von rows, cols oder boxs sein.
   Die Boxes und Columns werden zuerst in Zeilen transformiert, worauf dann pruneRow angewendet wird. 
   Hernach wieder Rückwandlung. Möglich, wenn  f.f = id gilt, was hier immer der Fall ist.
-}
pruneBy  :: (Matrix [Digit] -> Matrix [Digit]) -> Matrix [Digit] -> Matrix [Digit]
pruneBy f = f . map pruneRow . f


prune :: Matrix [Digit] -> Matrix [Digit]
prune = pruneBy boxs . pruneBy cols . pruneBy rows

-- die Auswahlmöglichkeiten einer Zelle
choices :: Grid -> Matrix [Digit]
choices = map (map choice)


choice d = if blank d then digits else [d]

cp :: [[a]] -> [[a]]
cp [] = [[]]
cp (xs:xss) = [x:ys | x <- xs, ys <- yss]
                  where yss = cp xss

expand :: Matrix [Digit] -> [Grid]
expand = cp . map cp

many :: Eq a => (a->a) -> a -> a
many f x = if x == y then x else many f y
         where y = f x


isSingle :: [a] -> Bool
isSingle [_] = True
isSingle _ = False

expand1 :: Matrix [Digit] -> [ Matrix[Digit] ]
expand1 rows  = [rows1 ++ [row1 ++ [c]:row2] ++ rows2 | c <- cs]
                 where     
                   (rows1,row:rows2) = break (any smallest ) rows
                   (row1,cs:row2) = break  smallest row
                   smallest cs = length cs == n
                   n = minimum (lengthInCellNotOne rows)

lengthInCellNotOne :: Matrix [Digit] -> [Int]
lengthInCellNotOne = filter (/=1) . map length . concat

complete :: Matrix [Digit] -> Bool
complete = all (all isSingle)

safe :: Matrix [Digit] -> Bool
safe m = all ok (rows m) && all ok (cols m) && all ok (boxs m) 

ok :: Eq a => Row  [a] -> Bool
ok row = nodups [x | [x] <- row]

extract :: Matrix [Digit] -> Grid
extract = map (map head)

-- searchM mit many prune, search nur einfaches prune; nur experimentell, bringt nicht viel
searchM ::Matrix [Digit] -> [Grid]
searchM  cm 
    | not (safe pm) = []
    | complete pm = [extract pm]
    | otherwise = concat . map searchM. expand1 $ pm
          where pm = many prune cm

solveM :: Grid -> [Grid]
solveM =  searchM . choices

search :: Matrix [Digit] -> [Grid]
search cm 
    | not (safe pm) = []
    | complete pm = [extract pm]
    | otherwise = concat . map search . expand1 $ pm
       where pm = prune cm

solve :: Grid -> [Grid]
solve =  search . choices

solveC :: CharGrid -> [CharGrid]
solveC = map intGridToChars . solve . charGridToDigits

solveS s = head . solveC $ stringToCharGrid s

flattenGrid :: CharGrid -> String
flattenGrid [] = ""
flattenGrid cg = head cg ++ flattenGrid (tail cg)

putLines :: String -> IO ()
putLines [] = return ()
putLines s = putStrLn (take 9 s) >>= return (putLines (drop 9 s))

main = do 
          args <- getArgs
          let result = flattenGrid . solveS $ head args 
          putStrLn result
          putLines result