Liyang/sudoku.hs

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