Liyang/sudoku.hs
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
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