summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDeterminant <ted.sybil@gmail.com>2017-06-18 00:21:46 -0400
committerDeterminant <ted.sybil@gmail.com>2017-06-18 00:21:46 -0400
commit09103516be58b5dbadcc636b952e541fef80dab6 (patch)
tree6b20b3af7628ed926cb003a81cc85fd5d95159eb
parentc99bbca8e61fdaa6662dfc5ee637153ce08bfe3f (diff)
finish all Haskell 99 problems
-rw-r--r--95-99/97.hs179
-rw-r--r--95-99/sudoku.c5
-rw-r--r--95-99/sudoku.in09
-rw-r--r--95-99/sudoku.in19
-rw-r--r--95-99/sudoku.in29
5 files changed, 210 insertions, 1 deletions
diff --git a/95-99/97.hs b/95-99/97.hs
index e69de29..ee44f87 100644
--- a/95-99/97.hs
+++ b/95-99/97.hs
@@ -0,0 +1,179 @@
+import Data.STRef.Lazy
+import Data.Array.ST (STArray, newArray, readArray, writeArray)
+import Data.Array.IArray (listArray)
+import Data.Array.Unboxed (UArray, (!))
+import Control.Monad.ST.Lazy
+import Control.Monad (replicateM, forM_, when)
+import Data.List
+--import System.IO.Unsafe (unsafePerformIO)
+
+data DNode s = DNode {left, right, up, down, ctl :: STRef s (DNode s),
+ size :: STRef s Int,
+ row, col :: Int} | Null
+
+instance Eq (DNode s) where
+ --Null == Null = True
+ --Null == (DNode _ _ _ _ _ _ _ _) = False
+ --(DNode _ _ _ _ _ _ _ _) == Null = False
+ a == b = row a == row b && col a == col b
+
+newDNode l r u d size row col =
+ do l' <- newSTRef l
+ r' <- newSTRef r
+ u' <- newSTRef u
+ d' <- newSTRef d
+ ctl' <- newSTRef Null
+ size' <- newSTRef size
+ return (DNode l' r' u' d' ctl' size' row col)
+
+getAttr :: (DNode s -> STRef s a) -> DNode s -> ST s a
+getAttr dir node = readSTRef (dir node)
+
+setAttr :: (DNode s -> STRef s a) -> DNode s -> a -> ST s ()
+setAttr dir node = writeSTRef (dir node)
+
+buildDLX :: [UArray Int Bool] -> Int -> Int -> ST s (DNode s)
+buildDLX bitmap nrow ncol =
+ do chead <- newArray (0, ncol - 1) Null :: ST s (STArray s Int (DNode s))
+ h <- newDNode Null Null Null Null 0 (-1) (-1)
+ setAttr left h h
+ setAttr right h h
+ setAttr up h h
+ setAttr down h h
+ forM_ [0..ncol-1] $ \j -> do
+ hl <- getAttr left h
+ p <- newDNode hl h Null Null 0 (-1) j
+ setAttr right hl p
+ setAttr left h p
+ setAttr up p p
+ setAttr down p p
+ writeArray chead j p
+ rhead <- newDNode Null Null Null Null 0 0 (-1)
+ forM_ (zip [0..nrow-1] bitmap) $ \(i, row) -> do
+ setAttr left rhead rhead
+ setAttr right rhead rhead
+ forM_ [0..ncol-1] $ \j -> do
+ if row ! j then do
+ rl <- getAttr left rhead
+ ct <- readArray chead j
+ cs <- getAttr size ct
+ setAttr size ct (cs + 1)
+ cu <- getAttr up ct
+ p <- newDNode rl rhead cu ct 0 i j
+ setAttr right rl p
+ setAttr left rhead p
+ setAttr down cu p
+ setAttr up ct p
+ setAttr ctl p ct
+ else return ()
+ rl <- getAttr left rhead
+ rr <- getAttr right rhead
+ setAttr right rl rr
+ setAttr left rr rl
+ return h
+
+forEach step start f = step start >>= loop
+ where loop now = when (now /= start) (f now >> step now >>= loop)
+
+forEach' step start f = step start >>= loop
+ where loop now = if now /= start then do
+ r <- f now
+ rs <- step now >>= loop
+ return (r:rs)
+ else return []
+
+setCover :: DNode s -> ST s ()
+setCover pctl =
+ do cl <- getAttr left pctl
+ cr <- getAttr right pctl
+ setAttr right cl cr
+ setAttr left cr cl
+ forEach (getAttr down) pctl $ \p ->
+ forEach (getAttr right) p $ \q -> do
+ qu <- getAttr up q
+ qd <- getAttr down q
+ qct <- getAttr ctl q
+ qcs <- getAttr size qct
+ setAttr down qu qd
+ setAttr up qd qu
+ setAttr size qct (qcs - 1)
+
+setUncover :: DNode s -> ST s ()
+setUncover pctl =
+ do cl <- getAttr left pctl
+ cr <- getAttr right pctl
+ setAttr right cl pctl
+ setAttr left cr pctl
+ forEach (getAttr up) pctl $ \p ->
+ forEach (getAttr left) p $ \q -> do
+ qu <- getAttr up q
+ qd <- getAttr down q
+ qct <- getAttr ctl q
+ qcs <- getAttr size qct
+ setAttr down qu q
+ setAttr up qd q
+ setAttr size qct (qcs + 1)
+
+solve bitmap ncol =
+ runST $ do dlx <- buildDLX bitmap (length bitmap) ncol
+ solve' dlx 0 []
+ where solve' head step plan =
+ do hl <- getAttr left head
+ if hl == head then
+ return [plan]
+ else do
+ best <- newSTRef (9999, Null)
+ forEach (getAttr right) head $ \p -> do
+ sp <- getAttr size p
+ (m, y) <- readSTRef best
+ when (sp < m)
+ (writeSTRef best (sp, p))
+ (m, y) <- readSTRef best
+ --y <- getAttr right head
+ setCover y
+ res <-
+ forEach' (getAttr down) y $ \p -> do
+ forEach (getAttr right) p $ \q -> do
+ qctl <- getAttr ctl q
+ setCover qctl
+ r' <- solve' head (step + 1) (row p:plan)
+ forEach (getAttr left) p $ \q -> do
+ qctl <- getAttr ctl q
+ setUncover qctl
+ return r'
+ setUncover y
+ return (concat res)
+
+sudoku :: [[Int]] -> [[[Int]]]
+sudoku prob = [[[d | y <- [0..blockN - 1],
+ d <- [1..blockN],
+ (x, y, d) `elem` pos] |
+ x <- [0..blockN - 1],
+ let pos = map (\x -> all!!x) sol] | sol <- solve bitmap colN]
+ where sudokuN = 3
+ blockN = sudokuN ^ 2
+ secN = blockN ^ 2
+ colN = secN * 4
+ fixed = filter (\(_, _, d) -> d /= 0) $
+ concatMap (\(r, l) -> (zipWith (\c x -> (r, c, x)) [0..]) l) (zip [0..] prob)
+ fixedPos = map (\(a, b, _) -> (a, b)) fixed
+ all = fixed ++ [(x, y, d) | x <- [0..blockN - 1], y <- [0..blockN - 1],
+ d <- [1..blockN], (x, y) `notElem` fixedPos]
+ makeBits [] n = replicate n False
+ makeBits (x:xs) n = replicate x False ++ (True:makeBits (map (\t -> t - x - 1) xs) (n - x - 1))
+ bitmap = [listArray (0, colN - 1) $
+ makeBits [x * blockN + y,
+ secN + ((x `div` sudokuN) * sudokuN + y `div` sudokuN) * blockN + d - 1,
+ secN * 2 + x * blockN + d - 1,
+ secN * 3 + y * blockN + d - 1] colN | (x, y, d) <- all]
+
+split _ [] = []
+split c s
+ | s' == [] = []
+ | otherwise = let (h, rest) = span (/= c) s' in h:split c rest
+ where s' = snd $ span (== c) s
+
+main = do lines <- replicateM 9 getLine
+ let prob = map (\l -> map read (split ' ' l) :: [Int]) lines
+ forM_ (sudoku prob) $ \sol -> do
+ putStrLn $ intercalate "\n" (map (\l -> intercalate " " (map show l)) sol) ++ "\n"
diff --git a/95-99/sudoku.c b/95-99/sudoku.c
index f8591f7..fee4829 100644
--- a/95-99/sudoku.c
+++ b/95-99/sudoku.c
@@ -45,6 +45,7 @@ DNode *build_dlx(int nrow, int ncol) {
(p->left = head->left)->right = p;
(p->right = head)->left = p;
p->up = p->down = p;
+ p->size = 0;
}
DNode *rhead = dnode_new(); /* helper node */
for (i = 0; i < nrow; i++)
@@ -55,6 +56,7 @@ DNode *build_dlx(int nrow, int ncol) {
{
DNode *p = dnode_new();
p->ctl = chead[j];
+ p->ctl->size++;
p->row = i;
(p->left = rhead->left)->right = p;
(p->right = rhead)->left = p;
@@ -136,7 +138,7 @@ void search(DNode *head, int step) {
LOOP(p, lp, down)
{
LOOP(q, p, right) set_cover(q->ctl);
- row_seq[step] = q->row;
+ row_seq[step] = p->row;
search(head, step + 1);
LOOP(q, p, left) set_uncover(q->ctl);
}
@@ -178,6 +180,7 @@ void sudoku() {
backref[nrow][2] = d + 1;
nrow++;
}
+ printf("%d\n", nrow);
head = build_dlx(nrow, SET_COVER_COL);
search(head, 0);
}
diff --git a/95-99/sudoku.in0 b/95-99/sudoku.in0
new file mode 100644
index 0000000..c62f057
--- /dev/null
+++ b/95-99/sudoku.in0
@@ -0,0 +1,9 @@
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0
diff --git a/95-99/sudoku.in1 b/95-99/sudoku.in1
new file mode 100644
index 0000000..16cf80f
--- /dev/null
+++ b/95-99/sudoku.in1
@@ -0,0 +1,9 @@
+0 5 0 0 6 0 0 0 1
+0 0 4 8 0 0 0 7 0
+8 0 0 0 0 0 0 5 2
+2 0 0 0 5 7 0 3 0
+0 0 0 0 0 0 0 0 0
+0 3 0 6 9 0 0 0 5
+7 9 0 0 0 0 0 0 8
+0 1 0 0 0 6 5 0 0
+5 0 0 0 3 0 0 6 0
diff --git a/95-99/sudoku.in2 b/95-99/sudoku.in2
new file mode 100644
index 0000000..d6f947b
--- /dev/null
+++ b/95-99/sudoku.in2
@@ -0,0 +1,9 @@
+0 0 0 0 6 0 0 8 0
+0 2 0 0 0 0 0 0 0
+0 0 1 0 0 0 0 0 0
+0 7 0 0 0 0 1 0 2
+5 0 0 0 3 0 0 0 0
+0 0 0 0 0 0 4 0 0
+0 0 4 2 0 1 0 0 0
+3 0 0 7 0 0 6 0 0
+0 0 0 0 0 0 0 5 0