Haskell solver that uses rules

8 files changed, 883 insertions, 16 deletions

diff --git a/.gitignore b/.gitignore
index af2ead4..94491a3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
 solve
+solve2
 *.o
 *.dSYM
 .DS_Store
diff --git a/Makefile b/Makefile
index ef6cc85..89c0b26 100644
--- a/Makefile
+++ b/Makefile
@@ -1,24 +1,14 @@
 CXX = g++
-CXXFLAGS = -Wall -Wextra -std=c++11 -fwrapv -g
-ifneq ($(DEBUG),)
-	CXXFLAGS += -g
-else
-	CXXFLAGS += -O2
-endif
-BIN = solve
+CXXFLAGS = -Wall -Wextra -std=c++11 -fwrapv -O2
+CXXTARGETS = solve solve2
 
 .PHONY: all clean remake
 
-all: $(BIN)
+all: $(CXXTARGETS)
 
 clean:
-	rm -rf $(BIN) *.o *.dSYM
+	rm -rf $(CXXTARGETS) *.o *.dSYM
 
-remake: clean all
 
-
-$(BIN): $(patsubst %.cpp,%.o,$(wildcard *.cpp))
-	$(CXX) -o $@ $^
-
-%.o: %.cpp $(wildcard *.h)
-	$(CXX) $(CXXFLAGS) -c -o $@ $<
+$(CXXTARGETS): %: %.cpp
+	$(CXX) $(CXXFLAGS) -o $@ $^
diff --git a/hsolve/.gitignore b/hsolve/.gitignore
new file mode 100644
index 0000000..fc6561a
--- /dev/null
+++ b/hsolve/.gitignore
@@ -0,0 +1,7 @@
+*.hi
+*.o
+.stack-work/
+.cabal-sandbox
+cabal.sandbox.config
+.DS_Store
+*.swp
\ No newline at end of file
diff --git a/hsolve/FSu.hs b/hsolve/FSu.hs
new file mode 100644
index 0000000..1bd250a
--- /dev/null
+++ b/hsolve/FSu.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables, RankNTypes #-}
+module FSu(solve) where
+
+import Control.Monad
+import Control.Monad.ST
+import Data.Array.ST
+import Data.STRef
+
+
+type Value = Int  -- Sudoku value
+type Index = Int  -- Sudoku index
+
+type Arr s a = STArray s Int a
+
+data State s = State { stateMark :: Arr s Bool, stateResults :: STRef s [[Maybe Value]] }
+
+solve :: [Maybe Value] -> [[Maybe Value]]
+solve input = runST $ do
+    arr <- newListArray (0,80) $ map (maybe (-1) id) input :: ST s (Arr s Value)
+    mark <- newArray (0,8) False :: ST s (Arr s Bool)
+    results <- newSTRef [] :: ST s (STRef s [[Maybe Value]])
+    solveAt arr 0 (State mark results)
+    readSTRef results
+
+obtainResult :: Arr s Value -> ST s [Maybe Value]
+obtainResult arr = do
+    elems <- getElems arr
+    return $ [if v == (-1) then Nothing else Just v | v <- elems]
+
+solveAt :: Arr s Value -> Index -> State s -> ST s ()
+solveAt arr !i st = do
+    valid <- isValid arr st
+    when valid $ do
+        if i == 81
+        then do
+            res <- obtainResult arr
+            modifySTRef' (stateResults st) (res:)
+        else do
+            v <- readArray arr i
+            if v /= (-1)
+            then solveAt arr (i+1) st
+            else do
+                poss <- getPoss arr i st
+                tryAll arr i poss st
+
+tryAll :: Arr s Value -> Index -> [Value] -> State s -> ST s ()
+tryAll _ _ [] _ = return ()
+tryAll arr !i (v:vs) st = do
+    writeArray arr i v
+    solveAt arr (i+1) st
+    writeArray arr i (-1)
+    tryAll arr i vs st
+
+-- assumes the considered position is empty
+getPoss :: forall s. Arr s Value -> Index -> State s -> ST s [Value]
+getPoss arr i st = do
+    fillArray mark 0 8 True
+    goRow (rowOf i) 0
+    goCol (colOf i) 0
+    goBlock (blockOrigin (blockOf i)) 0
+    bs <- liftM (zip [0..8]) (getElems mark)
+    return $ map fst $ filter snd bs
+  where
+    mark = stateMark st
+
+    goRow :: Int -> Int -> ST s ()
+    goRow _ 9 = return ()
+    goRow r j = readArray arr (9 * r + j) >>= \v ->
+        when (v /= (-1)) (writeArray mark v False) >> goRow r (j+1)
+
+    goCol :: Int -> Int -> ST s ()
+    goCol _ 9 = return ()
+    goCol c j = readArray arr (9 * j + c) >>= \v ->
+        when (v /= (-1)) (writeArray mark v False) >> goCol c (j+1)
+
+    goBlock :: Int -> Int -> ST s ()
+    goBlock _ 9 = return ()
+    goBlock b j = readArray arr (b + 9 * (j `quot` 3) + j `rem` 3) >>= \v ->
+        when (v /= (-1)) (writeArray mark v False) >> goBlock b (j+1)
+
+isValid :: forall s. Arr s Value -> State s -> ST s Bool
+isValid arr st = do
+    goRows 0 >>= \r1 -> if r1
+        then goCols 0 >>= \r2 -> if r2
+            then goBlocks 0
+            else return False
+        else return False
+  where
+    goRows, goCols, goBlocks :: Int -> ST s Bool
+    goRows 9 = return True
+    goRows i = isValidRow arr i st >>= \r -> if r then goRows (i+1) else return False
+
+    goCols 9 = return True
+    goCols i = isValidCol arr i st >>= \r -> if r then goCols (i+1) else return False
+
+    goBlocks 9 = return True
+    goBlocks i = isValidBlock arr i st >>= \r -> if r then goBlocks (i+1) else return False
+
+isValidRow :: Arr s Value -> Index -> State s -> ST s Bool
+isValidRow arr r st = indexSetNoDups arr [9 * r + i | i <- [0..8]] st
+
+isValidCol :: Arr s Value -> Index -> State s -> ST s Bool
+isValidCol arr c st = indexSetNoDups arr [9 * i + c | i <- [0..8]] st
+
+isValidBlock :: Arr s Value -> Index -> State s -> ST s Bool
+isValidBlock arr b st = indexSetNoDups arr [blockOrigin b + 9 * y + x| y <- [0..2], x <- [0..2]] st
+
+indexSetNoDups :: forall s. Arr s Value -> [Index] -> State s -> ST s Bool
+indexSetNoDups arr set st = do
+    fillArray mark 0 8 False
+    applyInMark set
+  where
+    mark = stateMark st
+
+    applyInMark :: [Int] -> ST s Bool
+    applyInMark [] = return True
+    applyInMark (i:is) =
+        readArray arr i >>= \v ->
+            if v == (-1)
+            then applyInMark is
+            else do
+                b <- readArray mark v
+                if b
+                then return False
+                else writeArray mark v True >> applyInMark is
+
+fillArray :: Arr s a -> Int -> Int -> a -> ST s ()
+fillArray arr !i1 !i2 v
+    | i1 <= i2 = do
+        writeArray arr i1 v
+        fillArray arr (i1 + 1) i2 v
+    | otherwise = return ()
+
+rowOf :: Index -> Index
+rowOf i = i `quot` 9
+
+colOf :: Index -> Index
+colOf i = i `rem` 9
+
+blockOf :: Index -> Index
+blockOf i = 3 * (i `quot` 27) + (i `rem` 9) `quot` 3
+
+blockOrigin :: Index -> Index
+blockOrigin 0 = 0
+blockOrigin 1 = 3
+blockOrigin 2 = 6
+blockOrigin 3 = 27
+blockOrigin 4 = 30
+blockOrigin 5 = 33
+blockOrigin 6 = 54
+blockOrigin 7 = 57
+blockOrigin 8 = 60
diff --git a/hsolve/Main.hs b/hsolve/Main.hs
new file mode 100644
index 0000000..015cb0f
--- /dev/null
+++ b/hsolve/Main.hs
@@ -0,0 +1,427 @@
+{-# LANGUAGE RankNTypes #-}
+module Main where
+
+import Control.Monad
+import Control.Monad.Writer
+import Data.Char
+import Data.Either
+import Data.List
+import Data.Maybe
+import System.Exit
+
+import qualified FSu
+
+
+lupdate :: Int -> a -> [a] -> [a]
+lupdate 0 v (_:xs) = v:xs
+lupdate i v (x:xs) = x : lupdate (i-1) v xs
+lupdate _ _ [] = error "Empty list in lupdate"
+
+b2i :: Bool -> Int
+b2i = fromEnum
+
+
+newtype Sudoku = Sudoku [Either Value Poss]  -- length 81
+  deriving (Show, Eq)
+
+type Value = Int
+
+newtype Poss = Poss [Bool]  -- length 9
+  deriving (Show, Eq)
+
+
+at :: Sudoku -> Int -> Either Value Poss
+at (Sudoku l) i = l !! i
+
+atv :: Sudoku -> Int -> Maybe Value
+atv su i = case at su i of
+    Left v -> Just v
+    Right _ -> Nothing
+
+atp :: Sudoku -> Int -> Poss
+atp su i = case at su i of
+    Left _ -> Poss (replicate 9 False)
+    Right p -> p
+
+update :: Int -> Either Value Poss -> Sudoku -> Sudoku
+update i v (Sudoku l) = Sudoku $ lupdate i v l
+
+listPoss :: [Value] -> Poss
+listPoss l = Poss [i `elem` l | i <- [0..8]]
+
+possList :: Poss -> [Value]
+possList (Poss m) = map snd $ filter fst $ zip m [0..8]
+
+possAnd :: Poss -> Poss -> Poss
+possAnd (Poss l1) (Poss l2) = Poss (zipWith (&&) l1 l2)
+
+possOr :: Poss -> Poss -> Poss
+possOr (Poss l1) (Poss l2) = Poss (zipWith (||) l1 l2)
+
+possElem :: Value -> Poss -> Bool
+possElem n (Poss l) = 0 <= n && n < 9 && l !! n
+
+possExact1 :: [Poss] -> Poss
+possExact1 [] = Poss (replicate 9 False)
+possExact1 ps = Poss $ map (== 1) $ foldl1 (zipWith (+)) $ map (\(Poss p) -> map b2i p) ps
+
+possMakeAllExcept :: Value -> Poss
+possMakeAllExcept n = Poss $ map (\i -> if i == n then False else True) [0..8]
+
+possGetIfInOne :: [Poss] -> Value -> Maybe Int
+possGetIfInOne ps n = case concatMap (\(p,i) -> if n `possElem` p then [i] else []) (zip ps [0..]) of
+    [i] -> Just i
+    _ -> Nothing
+
+
+backtrackSolve :: Sudoku -> [Sudoku]
+backtrackSolve (Sudoku l) = do
+    let ml = map (either Just (const Nothing)) l
+    res <- FSu.solve ml
+    let l' = map (maybe (Right (listPoss [0..8])) Left) res
+    return $ Sudoku l'
+
+
+data Region = Row Int Sudoku | Col Int Sudoku | Block Int Sudoku | Cell Int Sudoku
+  deriving (Show, Eq)
+
+rowOf :: Region -> Region
+rowOf (Cell i su) = Row (i `div` 9) su
+
+colOf :: Region -> Region
+colOf (Cell i su) = Col (i `mod` 9) su
+
+blockOf :: Region -> Region
+blockOf (Cell i su) = Block (3 * (i `div` 27) + (i `mod` 9) `div` 3) su
+
+valueOf :: Region -> Maybe Value
+valueOf (Cell i su) = su `atv` i
+
+possOf :: Region -> Poss
+possOf (Cell i su) = su `atp` i
+
+contentsOf :: Region -> Either Value Poss
+contentsOf (Cell i su) = su `at` i
+
+indexOf :: Region -> Int
+indexOf (Cell i _) = i
+
+
+sudokuOf :: Region -> Sudoku
+sudokuOf (Cell _ su) = su
+sudokuOf (Row _ su) = su
+sudokuOf (Col _ su) = su
+sudokuOf (Block _ su) = su
+
+indexRange :: Region -> [Int]
+indexRange (Cell _ _) = [0]
+indexRange (Row _ _) = [0..8]
+indexRange (Col _ _) = [0..8]
+indexRange (Block _ _) = [0..8]
+
+-- Doesn't check sudoku equality
+cellIsIn :: Region -> Region -> Bool
+cellIsIn (Cell i _) (Cell j _) = i == j
+cellIsIn (Cell i _) (Row r _) = i `div` 9 == r
+cellIsIn (Cell i _) (Col c _) = i `mod` 9 == c
+cellIsIn (Cell i _) (Block b _) = (i `mod` 9) `div` 3 == b `mod` 3 && i `div` 27 == b `div` 3
+
+adaptRegion :: Region -> Sudoku -> Region
+adaptRegion (Cell i _) su = Cell i su
+adaptRegion (Row i _) su = Row i su
+adaptRegion (Col i _) su = Col i su
+adaptRegion (Block i _) su = Block i su
+
+
+class HasCells a where
+    cell :: Int -> a -> Region
+
+instance HasCells Sudoku where
+    cell i su | 0 <= i && i < 81 = Cell i su
+
+instance HasCells Region where
+    cell i (Row r su) | 0 <= i && i < 9 = Cell (9 * r + i) su
+    cell i (Col c su) | 0 <= i && i < 9 = Cell (9 * i + c) su
+    cell i (Block b su) | 0 <= i && i < 9 =
+        let bx = 3 * (b `mod` 3)
+            by = 3 * (b `div` 3)
+        in Cell (9 * (by + i `div` 3) + bx + i `mod` 3) su
+    cell 0 c@(Cell _ _) = c
+    cell _ _ = undefined
+
+
+class HasValues a where
+    values :: a -> [Value]
+
+instance HasValues Sudoku where
+    values (Sudoku l) = lefts l
+
+instance HasValues Region where
+    values (Cell i su) = maybe [] pure (su `atv` i)
+    values reg = concatMap values [cell i reg | i <- indexRange reg]  -- row, col, block
+
+
+class UpdateValue a where
+    updateValue :: Int -> Value -> a -> Sudoku
+
+instance UpdateValue Sudoku where
+    updateValue i v su = update i (Left v) su
+
+instance UpdateValue Region where
+    updateValue 0 v (Cell j su) = update j (Left v) su
+    updateValue _ _ (Cell _ _) = undefined
+    updateValue i v reg = updateValue 0 v (cell i reg)  -- row, col, block
+
+
+class MaskPoss a where
+    maskPoss :: a -> Poss -> Sudoku
+
+instance MaskPoss Region where
+    maskPoss (Cell i su) p = case su `at` i of
+        Left _ -> su
+        Right p' -> update i (Right (p `possAnd` p')) su
+    maskPoss row@(Row   r _) p = sudokuOf $ foldl (\row' i -> Row   r $ maskPoss (cell i row') p) row [0..8]
+    maskPoss col@(Col   c _) p = sudokuOf $ foldl (\col' i -> Col   c $ maskPoss (cell i col') p) col [0..8]
+    maskPoss blk@(Block b _) p = sudokuOf $ foldl (\blk' i -> Block b $ maskPoss (cell i blk') p) blk [0..8]
+
+
+readSudoku :: String -> Sudoku
+readSudoku s = Sudoku $ flip map (words s) $ \w -> case w of
+    "." -> Right (Poss $ replicate 9 True)
+    [c] | '1' <= c && c <= '9' -> Left (ord c - ord '1')
+    _ -> error "Invalid sudoku input"
+
+writeSudokuGeneric :: Sudoku -> Bool -> String
+writeSudokuGeneric su full =
+    intercalate "\n"
+        [testinter n "\n" ++
+            intercalate " "
+                (map (\i -> testinter i " " ++ printone (su `atv` i) ++ printposs (su `atp` i)) [9*n..9*n+8])
+        | n <- [0..8]]
+  where
+    printone :: Maybe Value -> String
+    printone Nothing = "."
+    printone (Just n) = show (n + 1)
+
+    printposs :: Poss -> String
+    printposs (Poss m) =
+        let s = map snd $ filter fst $ zip m ['1'..'9']
+            padded = replicate (9 - length s) ' ' ++ s
+        in if full then "(" ++ padded ++ ")" else ""
+
+    testinter :: Int -> String -> String
+    testinter i s = let n = i `mod` 9 in if n > 0 && n `mod` 3 == 0 then s else ""
+
+writeSudoku :: Sudoku -> String
+writeSudoku su = writeSudokuGeneric su False
+
+writeSudokuFull :: Sudoku -> String
+writeSudokuFull su = writeSudokuGeneric su True
+
+writeSudokuDiff :: Sudoku -> Sudoku -> String
+writeSudokuDiff su1 su2 =
+    intercalate "\n" $ flip map [0..8] $ \r ->
+        let line = flip concatMap [0..8] $ \c ->
+                (if c > 1 && c `mod` 3 == 0 then " " else "")
+                ++ (if c > 1 then " " else "")
+                ++ case (su1 `at` (9 * r + c), su2 `at` (9 * r + c)) of
+                    (Left v1, Left v2) | v1 == v2 -> show (v2 + 1) ++ printposs pe pe
+                                       | otherwise -> high (show (v2 + 1)) ++ printposs pe pe
+                    (Left _, Right p) -> high ("." ++ printposs p p)
+                    (Right _, Left v) -> high (show (v + 1) ++ printposs pe pe)
+                    (Right p1, Right p2) -> "." ++ printposs p1 p2
+        in (if r > 1 && r `mod` 3 == 0 then "\n" else "") ++ line
+  where
+    high :: String -> String
+    high s = "\x1B[41;1m" ++ s ++ "\x1B[0m"
+
+    pe :: Poss
+    pe = listPoss []
+
+    printposs :: Poss -> Poss -> String
+    printposs (Poss m1) (Poss m2) =
+        let s = flip concatMap [0..8] $ \i -> case (m1 !! i, m2 !! i) of
+                    (True, True) -> show (i + 1)
+                    (True, False) -> high "."
+                    (False, True) -> high (show (i + 1))
+                    (False, False) -> " "
+        in "(" ++ s ++ ")"
+
+
+data Action = AResolve Int Value Reason
+            | AScratch Int Value Reason
+  deriving (Show)
+
+data Reason = RCell | RRow | RCol | RBlock
+            | RCellI Int | RRowI Int | RColI Int | RBlockI Int
+            | RCombine Reason Reason
+  deriving (Show)
+
+type SM = Writer [Action]
+
+reasonReg :: Region -> Reason
+reasonReg (Cell i _) = RCellI i
+reasonReg (Row r _) = RRowI r
+reasonReg (Col c _) = RColI c
+reasonReg (Block b _) = RBlockI b
+
+writeAction :: Action -> String
+writeAction (AResolve i n reason) =
+    "Resolved cell " ++ actionCellString i ++ " to value " ++ show (n + 1) ++ " (" ++ writeReason reason ++ ")"
+writeAction (AScratch i n reason) =
+    "Scratched possibility for " ++ show (n + 1) ++ " in cell " ++ actionCellString i ++ " (" ++ writeReason reason ++ ")"
+
+actionCellString :: Int -> String
+actionCellString i = "(" ++ show (i `mod` 9) ++ "," ++ show (i `div` 9) ++ ")"
+
+writeReason :: Reason -> String
+writeReason RCell = "cell"
+writeReason RRow = "row"
+writeReason RCol = "column"
+writeReason RBlock = "block"
+writeReason (RCellI i) = "situation in cell " ++ show i
+writeReason (RRowI i) = "situation in row " ++ show i
+writeReason (RColI i) = "situation in column " ++ show i
+writeReason (RBlockI i) = "situation in block " ++ show i
+writeReason (RCombine a b) = writeReason a ++ "; " ++ writeReason b
+
+
+scratchInRegionExcept :: Value -> Region -> Region -> Reason -> SM Sudoku
+scratchInRegionExcept val reg except reason =
+    foldM (\su i ->
+                let cl = cell i (adaptRegion reg su)
+                in if cl `cellIsIn` except
+                    then return su
+                    else if val `possElem` possOf cl
+                            then let su' = maskPoss cl (possMakeAllExcept val)
+                                 in tell [AScratch (indexOf cl) val reason] >> return su'
+                            else return su)
+          (sudokuOf reg) (indexRange reg)
+
+
+scratchPossBasic :: Sudoku -> (Sudoku, [Action])
+scratchPossBasic su =
+    let su1 = foldl (\su' regc -> scratchPossBasicRegion (regc su'))
+                su (concat [[Row i, Col i, Block i] | i <- [0..8]])
+    in (su1, [])
+
+scratchPossBasicRegion :: Region -> Sudoku
+scratchPossBasicRegion reg = maskPoss reg (listPoss $ [0..8] \\ values reg)
+
+scratchAroundCell :: Region -> Sudoku
+scratchAroundCell cl@(Cell _ _) =
+    let su1 = scratchPossBasicRegion (rowOf cl)
+        su2 = scratchPossBasicRegion (colOf (adaptRegion cl su1))
+        su3 = scratchPossBasicRegion (blockOf (adaptRegion cl su2))
+    in su3
+
+scratchPossIndirectB :: Sudoku -> (Sudoku, [Action])
+scratchPossIndirectB su = runWriter $ foldM bfunc su [0..8]
+  where
+    bfunc :: Sudoku -> Int -> SM Sudoku
+    bfunc su' bi =
+        let rowAllowed = flip map [0..2] $
+                \i -> [possOf $ cell (3 * i + j) (Block bi su') | j <- [0..2]]
+            colAllowed = flip map [0..2] $
+                \i -> [possOf $ cell (3 * j + i) (Block bi su') | j <- [0..2]]
+            rowIndices = scratchPairsFromAllowed rowAllowed
+            colIndices = scratchPairsFromAllowed colAllowed
+        in do
+            rowsu <- foldM (\su1 (i,n) ->  -- i: row number in block; n: value
+                            scratchInRegionExcept n (rowOf (cell (3 * i) (Block bi su1)))
+                                                  (Block bi su1) (RCombine (reasonReg (Block bi su1)) RRow))
+                           su' rowIndices
+            colsu <- foldM (\su1 (i,n) ->  -- i: row number in block; n: value
+                            scratchInRegionExcept n (colOf (cell i (Block bi su1)))
+                                                  (Block bi su1) (RCombine (reasonReg (Block bi su1)) RCol))
+                           rowsu colIndices
+            return colsu
+
+    -- return [(index, n)] for all the n that occur in only one blockrow
+    scratchPairsFromAllowed :: [[Poss]] -> [(Int, Value)]
+    scratchPairsFromAllowed plists =
+        let allowed = map (foldl1 possOr) plists
+        in catMaybes $
+            map (\(mi,n) -> maybe Nothing (\i -> Just (i,n)) mi) $
+                -- v [(Just index if n exists in only one blockrow and else Nothing, n)]
+                zip (map (possGetIfInOne allowed) [0..8]) [0..8]
+
+resolveCells :: Sudoku -> (Sudoku, [Action])
+resolveCells su = runWriter $ foldM func su [0..80]
+  where
+    func :: Sudoku -> Int -> SM Sudoku
+    func su' i = case possList (su' `atp` i) of
+        [n] -> do
+            tell [AResolve i n RCell]
+            let su1 = updateValue i n su'
+            return $ scratchAroundCell (cell i su1)
+        _ -> return su'
+
+resolveRegions :: Sudoku -> (Sudoku, [Action])
+resolveRegions su = runWriter $ foldM func su [f i | f <- [Row, Col, Block], i <- [0..8]]
+  where
+    func :: Sudoku -> (Sudoku -> Region) -> SM Sudoku
+    func su' regc =
+        foldM (\su1 n ->
+                    let reg = regc su1
+                        ps = map possOf [cell i reg | i <- indexRange reg]
+                    in case possGetIfInOne ps n of
+                        Nothing -> return su1
+                        Just i -> do
+                                    let su_i = indexOf (cell i reg)
+                                    tell [AResolve su_i n (reasonReg reg)]
+                                    let su2 = updateValue i n reg
+                                    return $ scratchAroundCell (cell su_i su2))
+              su' [0..8]
+
+
+operations :: [Sudoku -> (Sudoku, [Action])]
+operations = [
+    scratchPossBasic, scratchPossIndirectB,
+    resolveCells,
+    resolveRegions]
+
+solve :: Sudoku -> [(Sudoku, [Action])]
+solve su =
+    let l = tail $ go su operations
+        (su', _) = last l
+    in if su' == su then [] else l ++ solve su'
+  where
+    go :: Sudoku -> [Sudoku -> (Sudoku, [Action])] -> [(Sudoku, [Action])]
+    go su1 ops = scanl (\(su2, _) op -> op su2) (su1, []) ops
+
+main :: IO ()
+main = do
+    su <- liftM readSudoku getContents
+
+    let useBT = True
+        btSols = backtrackSolve su
+
+    when useBT $
+        case btSols of
+            [] -> do
+                die "Cannot solve sudoku using backtracking"
+            list -> do
+                putStrLn $ "Backtracking gave " ++ show (length list) ++ " solutions:"
+                forM_ list $ \res -> do
+                    putStrLn $ writeSudoku res
+                    putStr "\n"
+
+    let reslist = (su, []) : solve su
+        suRes = fst (last reslist)
+
+    putStrLn (writeSudokuFull su)
+
+    mapM_ (\((su', acts), (prevsu, _)) -> do
+                putStr "\n\n"
+                mapM_ (putStrLn . writeAction) acts
+                -- print acts
+                putStrLn (writeSudokuDiff prevsu su'))
+           (zip (tail reslist) reslist)
+
+    putStrLn (writeSudoku suRes)
+    putStr "\n"
+
+    when useBT $
+        when (length btSols /= 1 || suRes /= btSols !! 0) $
+            die "Incorrectly solved!"
diff --git a/hsolve/hsolve.cabal b/hsolve/hsolve.cabal
new file mode 100644
index 0000000..4489d0b
--- /dev/null
+++ b/hsolve/hsolve.cabal
@@ -0,0 +1,16 @@
+name:          hsolve
+version:       0.1.0
+cabal-version: >= 1.10
+build-type:    Simple
+license:       MIT
+author:        Tom Smeding
+maintainer:    tom.smeding@gmail.com
+
+executable            hsolve
+    hs-source-dirs:   .
+    main-is:          Main.hs
+    default-language: Haskell2010
+    ghc-options:      -Wall -O3 -Wno-incomplete-patterns
+    other-modules:    FSu
+    build-depends:    base >= 4 && < 5,
+                      mtl, array
diff --git a/hsolve/stack.yaml b/hsolve/stack.yaml
new file mode 100644
index 0000000..eb2d377
--- /dev/null
+++ b/hsolve/stack.yaml
@@ -0,0 +1,65 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-12.5
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
\ No newline at end of file
diff --git a/solve2.cpp b/solve2.cpp
new file mode 100644
index 0000000..84ab2a1
--- /dev/null
+++ b/solve2.cpp
@@ -0,0 +1,209 @@
+#include <iostream>
+#include <iomanip>
+#include <string>
+#include <cassert>
+
+using namespace std;
+
+
+struct Sudoku {
+	int bd[81];
+	bool poss[81][9];
+
+	int& operator[](int i) {return bd[i];}
+	const int& operator[](int i) const {return bd[i];}
+
+	int nposs(int i) const {
+		int t = 0;
+		for (int j = 0; j < 9; j++) {
+			t += poss[i][j];
+		}
+		return t;
+	}
+};
+
+istream& operator>>(istream &in, Sudoku &su) {
+	for (int i = 0; i < 81; i++) {
+		char c;
+		in >> c;
+		if (c == '.') {
+			su[i] = -1;
+		} else {
+			assert('1' <= c && c <= '9');
+			su[i] = c - '1';
+		}
+
+		for (int j = 0; j < 9; j++) {
+			su.poss[i][j] = true;
+		}
+	}
+	return in;
+}
+
+ostream& operator<<(ostream &os, const Sudoku &su) {
+	for (int y = 0; y < 9; y++) {
+		if (y != 0) {
+			os << endl;
+			if (y % 3 == 0) os << endl;
+		}
+
+		for (int x = 0; x < 9; x++) {
+			if (x != 0) {
+				os << ' ';
+				if (x % 3 == 0) os << ' ';
+			}
+			int v = su[9 * y + x];
+			if (v == -1) os << '.';
+			else os << v + 1;
+			string s;
+			for (int i = 0; i < 9; i++) {
+				if (su.poss[9 * y + x][i]) s += '1' + i;
+			}
+			// os << '(' << setw(9) << s << ')';
+		}
+	}
+
+	return os;
+}
+
+void cleanPossBase(Sudoku &su, bool print=true) {
+	for (int y = 0; y < 9; y++)
+	for (int x = 0; x < 9; x++) {
+		if (su[9 * y + x] != -1) {
+			for (int i = 0; i < 9; i++) {
+				su.poss[9 * y + x][i] = false;
+			}
+			continue;
+		}
+
+		for (int i = 0; i < 9; i++) {
+			if (i != x && su[9 * y + i] != -1 && su.poss[9 * y + x][su[9 * y + i]]) {
+				if (print) cerr << "Removed poss " << su[9 * y + i]+1 << " at " << i << " because same number in row" << endl;
+				su.poss[9 * y + x][su[9 * y + i]] = false;
+			}
+			if (i != y && su[9 * i + x] != -1 && su.poss[9 * y + x][su[9 * i + x]]) {
+				if (print) cerr << "Removed poss " << su[9 * i + x]+1 << " at " << i << " because same number in column" << endl;
+				su.poss[9 * y + x][su[9 * i + x]] = false;
+			}
+			int bx = x / 3 * 3 + i % 3;
+			int by = y / 3 * 3 + i / 3;
+			if ((bx != x || by != y) && su[9 * by + bx] != -1 && su.poss[9 * y + x][su[9 * by + bx]]) {
+				if (print) cerr << "Removed poss " << su[9 * by + bx]+1 << " at " << i << " because same number in block" << endl;
+				su.poss[9 * y + x][su[9 * by + bx]] = false;
+			}
+		}
+	}
+}
+
+void cleanPossIndirectRC(Sudoku &su) {
+	for (int n = 0; n < 9; n++) {
+		for (int bi = 0; bi < 9; bi++) {
+			bool haveR[3] = {false, false, false};
+			bool haveC[3] = {false, false, false};
+			int bx = bi % 3 * 3, by = bi / 3 * 3;
+
+			for (int y = by; y < by + 3; y++) {
+				for (int x = bx; x < bx + 3; x++) {
+					if (su.poss[9 * y + x][n]) {
+						haveR[y - by] = true;
+						haveC[x - bx] = true;
+					}
+				}
+			}
+
+			if (haveR[0] + haveR[1] + haveR[2] == 1) {
+				int y = by + 0 * haveR[0] + 1 * haveR[1] + 2 * haveR[2];
+				for (int x = 0; x < 9; x++) {
+					if (su.poss[9 * y + x][n]) {
+						cerr << "Removed poss " << n+1 << " at " << 9*y+x << " because row-local numbers in block " << bi << endl;
+						su.poss[9 * y + x][n] = false;
+					}
+				}
+			}
+
+			if (haveC[0] + haveC[1] + haveC[2] == 1) {
+				int x = bx + 0 * haveC[0] + 1 * haveC[1] + 2 * haveC[2];
+				for (int y = 0; y < 9; y++) {
+					if (by <= y && y < by + 3) continue;
+					if (su.poss[9 * y + x][n]) {
+						cerr << "Removed poss " << n+1 << " at " << 9*y+x << " because row-local numbers in block " << bi << endl;
+						su.poss[9 * y + x][n] = false;
+					}
+				}
+			}
+		}
+	}
+}
+
+bool applySingles(Sudoku &su) {
+	for (int i = 0; i < 81; i++) {
+		if (su.nposs(i) == 1) {
+			for (int j = 0; j < 9; j++) {
+				if (su.poss[i][j]) {
+					cerr << "Set " << i << " to " << j+1 << " since nposs=1" << endl;
+					su[i] = j;
+					return true;
+				}
+			}
+		}
+	}
+
+	return false;
+}
+
+bool applyOnlysB(Sudoku &su) {
+	for (int n = 0; n < 9; n++) {
+		for (int bi = 0; bi < 9; bi++) {
+			int bx = bi % 3 * 3, by = bi / 3 * 3;
+
+			int idx = -1;
+			for (int y = by; y < by + 3; y++) {
+				for (int x = bx; x < bx + 3; x++) {
+					if (su.poss[9 * y + x][n]) {
+						if (idx == -1) idx = 9 * y + x;
+						else goto nope_next;
+					}
+				}
+			}
+
+			if (idx != -1) {
+				cerr << "Set " << idx << " to " << n+1 << " since only there in block" << endl;
+				su[idx] = n;
+				return true;
+			}
+
+		nope_next: ;
+		}
+	}
+
+	return false;
+}
+
+bool performStep(Sudoku &su) {
+	cleanPossBase(su);
+	cleanPossIndirectRC(su);
+
+	if (applySingles(su)) return true;
+	if (applyOnlysB(su)) return true;
+
+	return false;
+}
+
+void solve(Sudoku &su) {
+	cleanPossBase(su, false);
+	while (performStep(su)) {
+		cout << su << endl << endl;
+	}
+}
+
+int main() {
+	cout << "This solver is incorrect. On suvh.txt, it gives a 5 on x=0 y=3, while that should be an 8." << endl;
+	return 1;
+
+	Sudoku su;
+	cin >> su;
+
+	solve(su);
+
+	cout << su << endl;
+}