Liyang/sudoku.hs
Jump to navigation
Jump to search
It's slow. That makes me sad.
sudoku.hs
{-# OPTIONS -cpp -fglasgow-exts -fno-monomorphism-restriction #-}
{- -}
#define EXHAUSTIVE 0
#define FORK_WORKERS 1
#define FORK_GUESSES 2
#define FORK_OS 4
#define FLAG(flag) (1 << flag)
#define OPTION(flag) (OPTIONS & FLAG(flag))
#ifndef OPTIONS
# define OPTIONS ( FLAG(FORK_WORKERS) )
{- |FLAG(FORK_GUESSES) |FLAG(EXHAUSTIVE) -}
#endif
module Main where
import Prelude hiding ( all, any, concat, elem, foldl, pi )
import Control.Arrow ( (***), (&&&) )
import Control.Applicative
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Data.Bits
import Data.Char
import Data.List ( intersperse, unfoldr )
import Data.Maybe
import Data.Monoid
import Data.Foldable
import Data.Traversable
import Data.Ix
--{{{ Tensor/Cartesian product on collections.
tensor :: (Applicative f, Applicative g) => (alpha -> beta -> gamma) -> f alpha -> g beta -> f (g gamma)
tensor f a b = (\ x -> f <$> pure x <*> b) <$> a
--}}}
--{{{ Indexable collections.
class Indexable f i | f -> i where
indexModify :: i -> (alpha -> (beta, alpha)) -> f alpha -> (beta, f alpha)
-- Sometimes we only want to index.
pi :: Indexable f i => i -> f alpha -> alpha
pi i = fst . indexModify i (id &&& id)
-- Or to just modify.
modify :: Indexable f i => i -> (alpha -> alpha) -> (f alpha -> f alpha)
modify i f = snd . indexModify i (id &&& f)
--}}}
--{{{ Three is the magic number: base three ordinals.
data Ti = T0 | T1 | T2 deriving (Show, Read, Bounded, Eq, Enum, Ord, Ix)
type TiTi = (Ti, Ti)
type Coord = (TiTi, TiTi)
boundedSize :: (Bounded alpha, Ix alpha) => alpha -> Int
boundedSize = rangeSize . (m0 &&& m1) where
m0, m1 :: Bounded alpha => alpha -> alpha
m0 w = minBound; m1 w = maxBound
fromPair :: (Bounded alpha, Ix alpha, Enum alpha) =>
(beta -> Int) -> (beta, alpha) -> Int
fromPair f (y, x) = boundedSize x * f y + fromEnum x
toPair :: (Bounded alpha, Ix alpha, Enum alpha) =>
(Int -> beta) -> Int -> (beta, alpha)
toPair f n = result where -- this is sick:
result = (f *** toEnum) (n `divMod` boundedSize (snd result))
instance
( Bounded alpha, Ix alpha, Enum alpha
, Bounded beta, Ix beta, Enum beta )
=> Enum (beta, alpha) where
fromEnum = fromPair fromEnum
toEnum = toPair toEnum
--}}}
--{{{ Triple: 3.
data Triple alpha = T alpha alpha alpha deriving (Show, Bounded, Eq, Ord, Ix)
instance Functor Triple where
fmap = fmapDefault
instance Foldable Triple where
foldMap = foldMapDefault
instance Traversable Triple where
traverse f (T x y z) = T <$> f x <*> f y <*> f z
iTriple = T T0 T1 T2
instance Indexable Triple Ti where
indexModify i f (T a b c) = case i of
T0 -> (x, T a' b c ) where (x, a') = f a
T1 -> (x, T a b' c ) where (x, b') = f b
T2 -> (x, T a b c' ) where (x, c') = f c
instance Applicative Triple where
pure x = T x x x
T f g h <*> T x y z = T (f x) (g y) (h z)
instance (Bounded alpha, Ix alpha, Enum alpha) => Enum (Triple alpha) where
fromEnum (T a b c) = (fromPair . fromPair) fromEnum ((a, b), c)
toEnum n = T a b c where ((a, b), c) = (toPair . toPair) toEnum n
instance Read alpha => Read (Triple alpha) where
readsPrec _ s = [ (T a b c, v) |
(a, t) <- reads s, (b, u) <- reads t, (c, v) <- reads u ]
showTriple :: String -> (alpha -> String) -> Triple alpha -> String
showTriple d s = concat . intersperse d . toList . fmap s
--}}}
--{{{ Region: 3x3; aka rows, cols, boxes, cell constraints... whatever.
newtype Region alpha = Region { unRegion :: Triple (Triple alpha) }
deriving Eq
instance Functor Region where
fmap = fmapDefault
instance Foldable Region where
foldMap = foldMapDefault
instance Traversable Region where
traverse f (Region tt) = Region <$> traverse (traverse f) tt
iRegion = Region (tensor (,) iTriple iTriple)
instance Indexable Region TiTi where
indexModify (j, i) f (Region tt) = (id *** Region) $
indexModify j (indexModify i f) tt
instance Applicative Region where
pure = Region . pure . pure
Region ttf <*> Region ttx = Region ((<*>) <$> ttf <*> ttx)
instance Read alpha => Read (Region alpha) where
readsPrec p s = (Region *** id) <$> readsPrec p s
instance Show alpha => Show (Region alpha) where
showsPrec _ = (++) . showTriple " " (showTriple " " show) . unRegion
--}}}
--{{{ Cell: 3x3; different Read/Show, but otherwise identical to Regions.
newtype Cell alpha = Cell { unCell :: Region alpha }
deriving Eq
instance Functor Cell where
fmap = fmapDefault
instance Foldable Cell where
foldMap = foldMapDefault
instance Traversable Cell where
traverse f (Cell r) = Cell <$> traverse f r
iCell = Cell iRegion
instance Indexable Cell TiTi where
indexModify ji f (Cell r) = (id *** Cell) (indexModify ji f r)
instance Applicative Cell where
pure = Cell . pure
Cell rf <*> Cell rx = Cell (rf <*> rx)
instance Read (Cell Bool) where
readsPrec _ s = case dropWhile isSpace s of
'{' : '-' : c : '-' : '}' : t -> reads (c : t)
'{' : a : b : c : '}' : t | all isOctDigit mask ->
[(partialCell, t)] where
mask = T a b c
partialCell = (Cell . Region . fmap (toEnum . digitToInt)) mask
c : t | c `elem` ".0_-?" ->
[(emptyCell, t)] where
emptyCell = (Cell . Region . pure . pure) True
c : t | c >= '1' && c <= '9' ->
[(fullCell, t)] where
fullCell = (Cell . Region . toEnum . (2 ^) . (8 -) . pred . read) [c]
_ -> []
instance Show (Cell Bool) where
show cell@(Cell (Region tt)) = case solutions cell of
[n] -> "{-" ++ show (fromEnum n + 1) ++ "-}"
_ -> "{" ++ showTriple "" (show . fromEnum) tt ++ "}"
--}}}
--{{{ Grid: 3x3 x 3x3
newtype Grid alpha = Grid { unGrid :: Region (Region alpha) }
deriving Eq
instance Functor Grid where
fmap = fmapDefault
instance Foldable Grid where
foldMap = foldMapDefault
instance Traversable Grid where
traverse f (Grid rr) = Grid <$> traverse (traverse f) rr
iGrid = Grid (tensor (,) iRegion iRegion)
instance Indexable Grid Coord where
indexModify (lk, ji) f (Grid rr) = (id *** Grid) $
indexModify lk (indexModify ji f) rr
instance Applicative Grid where
pure = Grid . pure . pure
Grid rrf <*> Grid rrx = Grid ((<*>) <$> rrf <*> rrx)
instance Read alpha => Read (Grid alpha) where
readsPrec p s = (Grid *** id) <$> readsPrec p s
instance Show alpha => Show (Grid alpha) where
show = showTriple "\n\n" (showTriple "\n" show) . unRegion . unGrid where
--}}}
--{{{ Cube: 3x3 x 3x3 x 3x3; grids with cell constraints.
newtype Cube alpha = Cube { unCube :: Grid (Cell alpha) }
deriving Eq
instance Functor Cube where
fmap = fmapDefault
instance Foldable Cube where
foldMap = foldMapDefault
instance Traversable Cube where
traverse f (Cube gc) = Cube <$> traverse (traverse f) gc
instance Applicative Cube where
pure = Cube . pure . pure
Cube gcf <*> Cube gcx = Cube ((<*>) <$> gcf <*> gcx)
instance Read (Cube Bool) where
readsPrec p s = (Cube *** id) <$> readsPrec p s
instance Show (Cube Bool) where
show = show . unCube
--}}}
--{{{ views: returns alternative representations of the grid.
type Auto alpha = alpha -> alpha
type Rank6 t alpha = t (t (t (t (t (t alpha)))))
views :: Cube alpha -> Region (Cube alpha)
views cube = (assemble . ($ disassemble cube)) <$> mkViews where
mkViews :: (Applicative t, Traversable t) => Region (Auto (Rank6 t alpha))
mkViews = (fmap traversals . Region) $ T
-- 0 1 2 3 4 5
-- J I l k n m -- row
-- l k J I n m -- col
-- l k n m J I -- bit
(T [0,1] [2,3] [4,5])
-- J l I k n m -- box
-- l k J n I m -- ?
-- I l k n J m -- ?
(T [0,2] [2,4] [4,0])
-- l J k I n m -- ?
-- l k n J m I -- ?
-- l I k n m J -- ?
(T [1,3] [3,5] [5,1])
disassemble :: Cube alpha -> Rank6 Triple alpha
disassemble = unRegion . fmap unRegion . unGrid . fmap (unRegion . unCell) . unCube
assemble :: Rank6 Triple alpha -> Cube alpha
assemble = Cube . fmap (Cell . Region) . Grid . fmap Region . Region
traversals :: (Applicative t, Traversable t) => [Int] -> Auto (Rank6 t alpha)
traversals = appEndo . fold . fmap (trs !!) . reverse . reindex where
trs :: (Applicative t, Traversable t) => [Endo (Rank6 t alpha)]
trs = Endo <$> [tr0, tr1, tr2, tr3, tr4, tr5] where
tr0 = id :: (Applicative t, Traversable t) => Auto (t alpha)
tr1 = traverse tr0 :: (Applicative t, Traversable t) => Auto (t (t alpha))
tr2 = traverse tr1 :: (Applicative t, Traversable t) => Auto (t (t (t alpha)))
tr3 = traverse tr2 :: (Applicative t, Traversable t) => Auto (t (t (t (t alpha))))
tr4 = traverse tr3 :: (Applicative t, Traversable t) => Auto (t (t (t (t (t alpha)))))
tr5 = traverse tr4 :: (Applicative t, Traversable t) => Auto (t (t (t (t (t (t alpha))))))
-- Calculate the traversals needed to obtain the required reindexing.
-- Not always the most efficient in terms of operations needed...
reindex :: [Int] -> [Int]
reindex = unfoldr shifts . reverse where
shifts [] = Nothing
shifts (0:t) = shifts t
shifts (1:0:t) = shifts t
shifts (h:t) = Just (h, flip fmap t $ \ d -> if h > d then d + 1 else d)
-- Just the rows, columns and boxes plzkthx.
decompose :: Cube alpha -> Triple (Cube alpha)
decompose grid = flip pi vs <$> T (T0, T0) (T0, T1) (T1, T0) where
vs = views grid
-- Select the relevalt row/col/box, given an (y, x) offset.
select :: Triple (Cube alpha) -> Coord -> Triple (Region (Cell alpha))
select rcbs ((l, k), (j, i)) = pi <$>
T (l, k) (j, i) (l, j) <*> (unGrid . unCube <$> rcbs)
--}}}
--{{{ solutions: produce a list of candidates, given a cell.
solutions :: Cell Bool -> [TiTi]
solutions = map fst . filter snd . (fmap (,) iCell <*>)
--}}}
--{{{ collapse: locate first non-solved cell with fewest possibilities and collapse it down.
collapse :: (Functor f, Foldable f, Enum i, Indexable f i) =>
f (Bool, Cell Bool) -> Maybe [f (Cell Bool)]
collapse cells = makeGrids <$> collapseMin cells where
makeGrids (sols, coord) =
[ modify coord (const cell) (snd <$> cells) | cell <- sols ]
collapseMin :: (Functor f, Foldable f, Enum i, Indexable f i) =>
f (Bool, Cell Bool) -> Maybe ([Cell Bool], i)
collapseMin = uncurry (fmap . const . fmap toEnum) . snd .
foldl minCell (0, (undefined, Nothing)) . fmap collapseCell where
-- undefined? Madness! But I want Ord (Maybe Int) on length and the
-- (fmap . const . fmap . toEnum) ensures the insanity never escapes
-- (counter :: Int, ((solutions :: [Cell Bool], index :: Int), length :: Maybe Int))
minCell :: (Int, (([Cell Bool], Int), Maybe Int)) ->
Maybe [Cell Bool] -> (Int, (([Cell Bool], Int), Maybe Int))
minCell (i, min@(_, lenThat)) = (,) (succ i) . maybe min choose where
choose this | lenThis > lenThat = ((this, i), lenThis)
| otherwise = min
where
-- |Ord alpha => Ord (Maybe alpha)| considers Nothing to be $\bot$,
-- rather than $\top$. We get the latter by flipping the ordering
-- on |alpha| (and swapping |(<)| with |(>)|), hence the |negate|.
lenThis = case length this of
1 -> Nothing
n -> Just (negate n) -- zero slips through!
collapseCell :: (Bool, Cell Bool) -> Maybe [Cell Bool]
collapseCell (True, cell) = Nothing
collapseCell (False, cell) =
Just (flip pi masks <$> solutions cell) where
masks = Cell <$> tensor (==) iRegion iRegion
--}}}
--{{{ Software Transactional Memory; forking.
instance Applicative STM where
pure = return
(<*>) = ap
type TBool = TVar Bool
#if FORK_OS
fork = forkOS
#else
fork = forkIO
#endif
--}}}
--{{{ eliminator: mark non-solutions from cells in the same row/col/box.
type Eliminator = TiTi -> STM ()
-- Make an eliminator, given a cell and its associated row/col/box.
-- Be careful not to mark the solution itself though.
eliminator :: Cell TBool -> Triple (Region (Cell TBool)) -> Eliminator
eliminator solution rcb n = elimRCB ((pi n <$>) <$> rcb) where
elimRCB :: Triple (Region TBool) -> STM ()
elimRCB = traverse_ . traverse_ $ \ tflag ->
unless (pi n solution == tflag) $ do
flag <- readTVar tflag
when flag (writeTVar tflag False)
--}}}
--{{{ worker: check each cell for changes in constraints.
worker :: TBool -> Cell TBool -> Eliminator -> STM ()
worker tsolved tcell elim = do
cell <- traverse readTVar tcell
case solutions cell of
[] -> do -- Bad End.
#if OPTION(FORK_WORKERS)
return ()
#else
retry
#endif
[n] -> do elim n; writeTVar tsolved True
_ -> retry
--}}}
--{{{ launchMissiles, waitMissiles: constraint propagation.
type State alpha = (Grid alpha, Cube alpha)
#if OPTION(FORK_WORKERS)
waitMissiles :: State TBool -> STM ()
waitMissiles (tsolved, Cube tgrid) = do
let boo tmarked tcell = do
marked <- readTVar tmarked
cell <- solutions <$> traverse readTVar tcell
case cell of
[] -> return False
[_] -> do unless marked retry; return True
_ -> return True
let elseThen _ t True = t
elseThen e _ False = e
foldrM (elseThen (return False)) True (boo <$> tsolved <*> tgrid :: Grid (STM Bool))
return ()
#endif
launchMissiles :: State Bool -> IO (State Bool)
launchMissiles (solved, cube) = do
tsolved <- atomically $ traverse newTVar solved
tcube@(Cube tgrid) <- atomically $ traverse newTVar cube
let tcubes = decompose tcube :: Triple (Cube TBool)
let elims = {-# SCC "elims" #-} eliminator <$> tgrid <*> (select tcubes <$> iGrid) :: Grid Eliminator
let workers = {-# SCC "workers" #-} worker <$> tsolved <*> tgrid <*> elims :: Grid (STM ())
#if OPTION(FORK_WORKERS)
let whip True _ = {-# SCC "whip" #-} return Nothing
whip False w = Just <$> fork (atomically w)
tids <- {-# SCC "whipping" #-} sequenceA (whip <$> solved <*> workers)
-- Wait for all the missiles to hit their target. Or any to malfunction.
atomically (waitMissiles (tsolved, tcube))
traverse_ (traverse_ killThread) tids
#else
tdone <- atomically (newTVar False)
let whip rest (tdone, w) = do
done <- readTVar tdone
if done then rest
else w `orElse` rest
let loop = do
atomically (foldl whip (writeTVar tdone True) ((,) <$> tsolved <*> workers))
done <- atomically (readTVar tdone)
unless done loop
loop
#endif
cube' <- atomically (traverse readTVar tcube)
solved' <- atomically (traverse readTVar tsolved)
return (solved', cube')
--}}}
--{{{ mad: make guesses.
mad :: State Bool -> IO Bool
mad boo = do
(solved', cube') <- launchMissiles boo
case fmap Cube <$> collapse ((,) <$> solved' <*> unCube cube') of
Nothing -> do
print cube'
return True
Just next -> case next of
[] -> return False -- Bad End.
_ -> do
#if OPTION(FORK_GUESSES)
children <- for next $ \ c -> do
sem <- atomically (newTVar Nothing)
tid <- fork $ mad (solved', c) >>= atomically . writeTVar sem . Just
return (sem, tid)
let wait = do
done <- atomically (traverse (readTVar . fst) children)
# if OPTION(EXHAUSTIVE)
if any isNothing done
then wait
else return (any (fromMaybe False) done)
# else
if any (fromMaybe False) done
then do
traverse_ (killThread . snd) children
return True
else if case any isNothing done
then wait
else return False
# endif
wait
#else
# if OPTION(EXHAUSTIVE)
traverse_ (mad . (,) solved') next
return True -- don't care
# else
let cow True _ = return True
cow False c = mad (solved', c)
foldlM cow False next
# endif
#endif
--}}}
--{{{ go, main: solver entry point.
go :: Cube Bool -> IO Bool
go = mad . (,) (pure False)
main :: IO ()
main = do
go . read =<< getContents
return ()
--}}}
--{{{ easy, gentle, diabolical, unsolvable, minimal :: Cube Bool
easy, gentle, diabolical, unsolvable, minimal :: Cube Bool
easy = read "\
2....1.38\
........5\
.7...6...\
.......13\
.981..257\
31....8..\
9..8...2.\
.5..69784\
4..25...."
gentle = read "\
.1.42...5\
..2.71.39\
.......4.\
2.71....6\
....4....\
6....74.3\
.7.......\
12.73.5..\
3...82.7."
diabolical = read "\
.9.7..86.\
.31..5.2.\
8.6......\
..7.5...6\
...3.7...\
5...1.7..\
......1.9\
.2.6..35.\
.54..8.7."
unsolvable = read "\
1..9.7..3\
.8.....7.\
..9...6..\
..72.94..\
41.....95\
..85.43..\
..3...7..\
.5.....4.\
2..8.6..9"
minimal = read "\
.98......\
....7....\
....15...\
1........\
...2....9\
...9.6.82\
.......3.\
5.1......\
...4...2."
--}}}
Makefile
TARGETS := sudoku HSFLAGS := $(DEFINES) -O3 .PHONY: all alternatives all: $(TARGETS) %: %.hs ghc $(HSFLAGS) -threaded -o $@ --make $< %: %.lhs ghc $(HSFLAGS) -threaded -o $@ --make $< profile-%: %.hs ghc $(HSFLAGS) -prof -auto-all -o $@ --make $< profile-%.prof: profile-% ./$< +RTS -p -i0.02 -RTS .PHONY: clean clean: rm -f $(TARGETS:=.o) $(TARGETS:=.hi) $(TARGETS)
build-alternatives
#! /bin/bash
NAME=sudoku
for ((i = 0; i < 16; i++)) ; do
EXT=""
[ "$(($i & 1))" = "0" ] || EXT="$EXT-exhaustive"
[ "$(($i & 2))" = "0" ] || EXT="$EXT-fork_workers"
[ "$(($i & 4))" = "0" ] || EXT="$EXT-fork_guesses"
[ "$(($i & 8))" = "0" ] || EXT="$EXT-forkOS"
EXT="${EXT:--boring}"
make clean
make DEFINES="-DOPTIONS=$i" "$NAME"
mv "$NAME" "$NAME$EXT"
done