Am Freitag, 7. April 2006 01:50 schrieben Sie:
> On Apr 6, 2006, at 6:05 PM, Daniel Fischer wrote:
> > I've also written a version using David F. Place's EnumSet instead
> > of [Int],
> > that takes less MUT time, but more GC time, so is slower on the
> > 36,628 test,
> > but faster for a single puzzle.
>
> That's a curious result. Did you compile with optimization? It
I considered that curious, too.
Everything was compiled with -O2 (does -O3 give better results?, would adding
-optc-On improve performance? I'll try).
What makes it even weirder is that the EnumSet-version does indeed allocate
fewer bytes and performs fewer garbage collections (small difference,
though).
But I got consistent results, when running on a large number of puzzles, the
list-version's faster gc'ing led to shorter overall run times.
The same held when compiled with -O3 -optc-O3, however, I've been stupid,
my excuse is that I was ill this week, the list version spent 46.5% gc'ing and
the set version 53.5%, which is not really cricket, so today I used -AxM,
x <- [10,16,32,64], all reducing GC time to reasonable 0.5 - 2%. That, plus a
few polishings, reduced the running time to about 16 minutes for EnumSet, a
little more for lists.
But, lo and behold, I also tried how plai Array fared in comparison to
DiffArray and ... reduced the running time to under ten minutes (a little
above for the list version), 5% GC time without -AxM, 1.2% with -A8M.
And I thought, DiffArrays were supposed to be fast!
> should compile into primitive bit-twiddling operations and do no
> allocating at all. I'd be curious to see how fast my solver works on
Well, since I've wrapped the sets in the Entry datatype, I wouldn't expect
that, switching from Poss (singleton k) to Def k costs.
I tried making Board a DiffArray (Int,Int) (Set Int), but then I had the
problem that either I lost the information gained by placing & forbidding for
those positions where the number of possibilities dropped to one by
inference, or had to scan the grid and re-place every now and then, both
resulting in poor performance.
> the 36,628 test. I'm afraid to run my ancient limping powerbook in
> such a tight loop for that long. It gets too hot!
>
> If you'd find it amusing to give it a whirl, I'd love to know the
> result.
I ran your incrsud on the first fifteen 17-hint puzzles, took over 20s, so I
decided against the full 36,628 test. Extrapolation makes me believe it'd
take thirteen to fourteen hours.
The really big thing is to include the "if there is only one place to put a
number in a row/column/cell, then put it there" inference step. Further
inference has smaller impact (but the group-inference bought me a 20%
speedup, which isn't bad, is it?).
But using Array instead of DiffArray gave almost 40%, that's impressive.
Attached is the fastest version I have, oddly, compiled with -O2 it's faster
than with -O3 -optc-O3 (on my computer), how come?
setUni +RTS -A8M -sstderr
True
99,859,933,904 bytes allocated in the heap
104,713,900 bytes copied during GC
150,260 bytes maximum residency (72 sample(s))
11558 collections in generation 0 ( 6.83s)
72 collections in generation 1 ( 0.16s)
13 Mb total memory in use
INIT time 0.00s ( 0.00s elapsed)
MUT time 554.68s (568.29s elapsed)
GC time 6.99s ( 7.22s elapsed)
EXIT time 0.00s ( 0.00s elapsed)
Total time 561.67s (575.51s elapsed)
%GC time 1.2% (1.3% elapsed)
Alloc rate 180,031,610 bytes per MUT second
Productivity 98.8% of total user, 96.4% of total elapsed
an average of 0.015s per 17-hint puzzle, cool!
Cheers,
Daniel
>
> --------------------------------
> David F. Place
> mailto:[EMAIL PROTECTED]
--
"In My Egotistical Opinion, most people's C programs should be
indented six feet downward and covered with dirt."
-- Blair P. Houghton
module SudokuSet where
import Data.Array
import Data.List (unfoldr, intersperse, sortBy, nub)
import Data.Char (isDigit, digitToInt)
import System.IO
import qualified EnumSet as Set (null)
import EnumSet (Set, (\\), size, member, empty,
delete, unions, intersection, toList,
fromList, singleton, findMin, fold)
type Position = (Int, Int)
pool :: Entry
pool = Poss $ fromList [1 .. 9]
ixes :: [Int]
ixes = [0 .. 8]
data Entry
= Def !Int -- ^ definite entry
| Poss !(Set Int) -- ^ set of possibilities at a position
deriving Eq
-- Show instance, the Poss case comes from the original design,
-- where a sudoku puzzle was solved step by step
instance Show Entry where
show (Def k) = show k
show (Poss s) = case size s of
0 -> "#"
1 -> "*"
2 -> ":"
_ -> " "
-- was a DiffArray, however this is MUCH faster
type Board = Array Position Entry
emptyBoard :: Board
emptyBoard = listArray ((0,0),(8,8)) $ replicate 81 pool
-- get the entry in (cellNo, cellInd) form
(?) :: Board -> Position -> Entry
b ? p = b ! toGridPos p
-- a puzzle is unsolvable if at any position, we can't place a number
failed :: Board -> Bool
failed = any isImp . elems
-- the puzzle is solved, if we have entered a number at all positions,
-- the constraints are guarded by the place & forbid connection
solved :: Board -> Bool
solved = all isDef . elems
-- has this board exactly one solution?
unique :: Board -> Bool
unique b = case solve b of
[_] -> True
_ -> False
----------------------------------------------------------------------
-- Solving a Puzzle --
----------------------------------------------------------------------
-- place a number at a position, if that's possible
--
-- if there is already a number, either it is the one we want to
-- place, in which case we do nothing, or it is another one, in
-- which case we make our board failed (actually the latter can't
-- occur, I think)
--
-- if the number is still allowed at the position, we put it there
-- and forbid it at the other positions in the same row,
-- column and cell
place :: Board -> Position -> Int -> Board
place b p@(r,c) k
= case b!p of
Def n -> if k == n then b
else b // [(p, Poss empty)]
Poss s -> if k `member` s then b'
else b // [(p, Poss empty)]
where
b1 = b // [(p,Def k)]
ri = [(r,i) | i <- ixes, i /= c]
ci = [(i,c) | i <- ixes, i /= r]
cn = cellNo p
good (x,y) = x /= r && y /= c
bi = filter good [toGridPos (cn,i) | i <- ixes]
b' = foldl (forbid k) b1 $ ri ++ ci ++ bi
-- restrict the possibilities at a position to the members of a set,
-- if that's a singleton, we 'place' its only element
-- the Def case is never used, only present for completeness
restrict :: Board -> (Position, Set Int) -> Board
restrict b (p,s)
| size s == 1 = place b p $ findMin s
| otherwise = case b!p of
Poss t -> b // [(p, Poss $ intersection s t)]
Def k -> if k `member` s then b
else b // [(p, Poss empty)]
-- forbid a number at a position, only if it is one of the
-- possibilities need we do anything (we never try to forbid
-- a number previously placed)
forbid :: Int -> Board -> Position -> Board
forbid k b p
= case b!p of
Poss s | k `member` s -> b // [(p, Poss $ delete k s)]
_ -> b
-- list of determined (Position, Int) pairs
certs :: Board -> [(Position, Int)]
certs b = [(p,findMin s) | (p, Poss s) <- assocs b, size s == 1]
-- define (i.e. 'place') all determined entries, if that leads
-- to further determined entries, recurse; and tell us whether
-- we have defined anything
defCerts :: Board -> (Bool, Board)
defCerts b
= case certs b of
[] -> (False, b)
cs -> let b1 = foldl (uncurry . place) b cs
(_, b2) = defCerts b1
in (True, b2)
-- find the possible positions of number 'k' in cell 'cn',
-- if there is only one, place it there, if all are in one
-- row (column), we 'forbid' 'k' on that row (column) in
-- the other cells
posCell :: Int -> Board -> Int -> Board
posCell cn b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b?(cn,i), not (isDef e)]
fp = findPos k ps
rs = nub [i `quot` 3 | i <- fp]
cs = nub [i `rem` 3 | i <- fp]
rc = filter (/= cn) [(cn `quot` 3) * 3 + i | i <- [0 .. 2]]
cc = filter (/= cn) [3 * i + (cn `rem` 3) | i <- [0 .. 2]]
ls = case (rs,cs) of
([r], _) -> [(c',3*r+i) | c' <- rc, i <- [0 .. 2]]
(_, [c]) -> [(c',3*i+c) | c' <- cc, i <- [0 .. 2]]
_ -> []
in case fp of
[i] -> place b (toGridPos (cn,i)) k
_ -> foldl (forbid k) b $ map toGridPos ls
-- do 'posCell' for all numbers not yet placed in cell no 'cn'
treatCell :: Int -> Board -> Board
treatCell cn b
= fold (posCell cn) b st
where
st = unions [mkSt e | i <- ixes, let e = b?(cn,i), not (isDef e)]
-- do the above for all cells
treatCells :: Board -> Board
treatCells b = foldr treatCell b [0 .. 8]
-- find the possible positions of 'k' in row 'r', if there's
-- only one, place it, if all are in one cell, forbid 'k' in
-- the other rows of that cell
posRow :: Int -> Board -> Int -> Board
posRow r b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b!(r,i), not (isDef e)]
fp = findPos k ps
cs = nub [i `quot` 3 | i <- fp]
in case (fp,cs) of
([c],_) -> place b (r,c) k
(_,[c]) -> let ls = [(r',c') | i <- [0 .. 2]
, let r' = 3*(r `quot` 3) + i, r' /= r
, j <- [0 .. 2], let c' = 3*c + j]
in foldl (forbid k) b ls
_ -> b
-- do 'posRow' for all numbers not yet placed in row 'r'
treatRow :: Int -> Board -> Board
treatRow r b
= fold (posRow r) b st
where
st = unions [mkSt s | i <- ixes, let s = b!(r,i), not (isDef s)]
-- do the above for all rows
treatRows :: Board -> Board
treatRows b = foldr treatRow b [0 .. 8]
-- find the possible positions of 'k' in column 'c', if there's
-- only one, place it, if all are in one cell, forbid 'k' in
-- the other columns of that cell
posCol :: Int -> Board -> Int -> Board
posCol c b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b!(i,c), not (isDef e)]
fp = findPos k ps
rs = nub [i `quot` 3 | i <- fp]
in case (fp,rs) of
([r],_) -> place b (r,c) k
(_,[r]) -> let ls = [(r',c') | i <- [0 .. 2]
, let r' = 3*r + i, j <- [0 .. 2]
, let c' = 3*(c `quot` 3) + j, c' /= c]
in foldl (forbid k) b ls
_ -> b
-- do 'posCol' for all numbers not yet placed in column 'c'
treatCol :: Int -> Board -> Board
treatCol c b
= fold (posCol c) b st
where
st = unions [mkSt s | i <- ixes, let s = b!(i,c), not (isDef s)]
-- do the above for all columns
treatCols :: Board -> Board
treatCols b = foldr treatCol b [0 .. 8]
-- infer until we either have determined (but not yet placed)
-- some entries or don't make any progress (e.g. when we've
-- solved our puzzle)
infer :: Board -> Board
infer b
= let b1 = treatCells b
c1 = certs b1
b2 = treatRows b1
c2 = certs b2
b3 = treatCols b2
c3 = certs b3
b4 = treatGroups b3
c4 = certs b4
in case (c1,c2,c3,c4) of
((_:_),_,_,_) -> b1
(_,(_:_),_,_) -> b2
(_,_,(_:_),_) -> b3
(_,_,_,(_:_)) -> b4
_ -> if b4 == b then b4 else infer b4
-- find a position with the fewest possible entries and return
-- the list of boards with that position filled accordingly
guess :: Board -> [Board]
guess b
= let ass = filter (not . isDef . snd) $ assocs b
cmp (_,Poss s1) (_,Poss s2) = compare (size s1) (size s2)
sas = sortBy cmp ass
in case sas of
[] -> []
((p,Poss s):_) -> [place b p n | n <- toList s]
-- create the list of all solutions of a board
--
-- if it's already solved, there obviously is only one solution
-- if the board is failed, there is none
-- otherwise we infer as much as we can and concat all solutions
-- of all guesses
solve :: Board -> [Board]
solve b
| solved b = [b]
| failed b = []
| otherwise = let b1 = infer b in
case defCerts b1 of
(True,b2) -> solve b2
(_ ,b2) -> if b == b2 then
do bd <- guess b
solve bd
else solve b2
----------------------------------------------------------------------
-- Inference on Groups --
----------------------------------------------------------------------
-- group inference:
-- from a group of positions (one cell/column/row) we select
-- k as yet unfilled positions and consider the set of all
-- numbers allowed at one of these, if this set has k members,
-- we know that they can't appear anywhere else in that cell/
-- column/row
-- if that set has fewer than k members, our board will fail,
-- so we do it as quickly as possible
--
-- this also treats the dual problem: if we take a set of k
-- numbers and have altogether k possible positions for them,
-- then no other number can appear at any of these positions
inferGroup :: Board -> [Position] -> [[(Position, Set Int)]]
inferGroup b ps
= let ass = [(p,b!p) | p <- ps]
sts = [(p,s) | (p, Poss s) <- ass]
len = length sts
in do k <- [2 .. len - 2]
(xs,ys) <- select k sts
let ws = unions $ map snd xs
case compare (size ws) k of
GT -> fail "nothing found"
LT -> return [(p,empty) | (p,_) <- sts]
_ -> return $ map (`without` ws) ys
-- apply the restriction inferred by 'inferGroups'
infGr :: Board -> [Position] -> Board
infGr b ps
= let ups = concat $ inferGroup b ps
in foldl restrict b ups
-- list of (list of) positions in one cell, row, column
indGroups :: [[Position]]
indGroups = [map toGridPos [(cn,i) | i <- ixes] | cn <- ixes]
++ [[(r,c) | c <- ixes] | r <- ixes]
++ [[(r,c) | r <- ixes] | c <- ixes]
-- apply the above inference to all cells, rows, columns
treatGroups :: Board -> Board
treatGroups b = foldl infGr b indGroups
----------------------------------------------------------------------
-- Reading and Displaying a Board --
----------------------------------------------------------------------
-- read a board in line-format
readLine :: String -> Board
readLine str
= let nlns = zip [0 .. 8] $ takeBy 9 str
tr s = zip [0 .. 8] $ map digitToInt s
grd = map (\(n,l) -> map (\(k,m) -> ((n,k),m)) $ tr l) nlns
plcs = filter ((/= 0) . snd) $ concat grd
in foldl (uncurry . place) emptyBoard plcs
-- read a board in either line or grid format
readBoard :: String -> Board
readBoard = readLine . take 81 . filter isDigit
-- make a list of lists out of an array
boardToLists :: Board -> [[Entry]]
boardToLists b = [[b!(r,c) | c <- ixes] | r <- ixes]
-- String representation, unashamedly stolen from David F. Place's
-- solver, because it's much prettier than my original display
display :: [[Entry]] -> String
display s = stretch . (intersperse ["---+---+---\n"]) . (stitch knot) . gather $ s
where
sewRow = stretch . (intersperse ["|"]) . (stitch show) . gather
knot r = (sewRow r)++['\n']
stretch = concat . concat
stitch f = map (map f)
gather = takeBy 3
-- show a board in nice format
showBoard :: Board -> String
showBoard = display . boardToLists
-- pretty-print a board
pretty :: Board -> IO ()
pretty = putStr . showBoard
----------------------------------------------------------------------
-- Helper Functions --
----------------------------------------------------------------------
-- calculate the cell number of a position
cellNo :: Position -> Int
cellNo (r,c) = (r `quot` 3) * 3 + c `quot` 3
-- calculate the index of a position in the cell
cellInd :: Position -> Int
cellInd (r,c) =(r `rem` 3) * 3 + c `rem` 3
-- transform from (row, column) to (cell, index) format
toCellPos :: Position -> Position
toCellPos p = (cn,ci)
where
cn = cellNo p
ci = cellInd p
-- transform from (cell, index) to (row, column) format
toGridPos :: Position -> Position
toGridPos = toCellPos
-- also from David F. Places solver
takeBy :: Int -> [a] -> [[a]]
takeBy n xs = unfoldr f xs
where
f [] = Nothing
f xs = Just $ splitAt n xs
isDef :: Entry -> Bool
isDef e = case e of
Def _ -> True
_ -> False
isImp :: Entry -> Bool
isImp e = case e of
Poss s | Set.null s -> True
_ -> False
findPos :: Int -> [(Int, Set Int)] -> [Int]
findPos k ps = [y | (y,s) <- ps, k `member` s]
mkSt :: Entry -> Set Int
mkSt e = case e of
Poss s -> s
Def k -> singleton k
-------------------------------------------------------
select :: Int -> [a] -> [([a],[a])]
select 0 xs = [([],xs)]
select _ [] = []
select n (x:xs) = [(x:ys,zs) | (ys,zs) <- select (n-1) xs]
++ [(ys,x:zs) | (ys,zs) <- select n xs]
without :: (a,Set Int) -> Set Int -> (a,Set Int)
(x,st) `without` ts = (x, st \\ ts)
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
