finish all Haskell 99 problems

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