set-cover-0.0.7: example/Sudoku.hs

{-
<https://en.wikipedia.org/wiki/Sudoku>
-}
module Main where

import qualified Math.SetCover.BitSet as BitSet
import qualified Math.SetCover.Bit as Bit
import qualified Math.SetCover.Exact as ESC

import Data.Word (Word32, Word64)

import Control.Monad (liftM3, guard)

import qualified Data.Array as Array
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Foldable (foldMap)
import Data.Array (array)
import Data.Set (Set)
import Data.List.HT (sliceVertical)
import Data.List (intersperse)


data X = Pos Int Int | Row Int Int | Column Int Int | Square Int Int Int
         deriving (Eq, Ord, Show)

type Assign = ESC.Assign ((Int, Int), Int)

assign :: Int -> Int -> Int -> Assign (Set X)
assign k i j =
   ESC.assign ((i,j), k) $
   Set.fromList [Pos i j, Row k i, Column k j, Square k (div i 3) (div j 3)]

assigns :: [Assign (Set X)]
assigns = liftM3 assign [1..9] [0..8] [0..8]


type Word81 = Bit.Sum Word64 Word32
type Mask =
   BitSet.Set
      (Bit.Sum
         (Bit.Sum Word81 Word81)
         (Bit.Sum Word81 Word81))

bit9x9 :: Int -> Int -> Word81
bit9x9 i j =
   let k = i*9+j
   in  if k<64
         then Bit.bitLeft k
         else Bit.bitRight (k-64)

bitAssign :: Int -> Int -> Int -> Assign Mask
bitAssign k i j =
   ESC.assign ((i,j), k) $
   BitSet.Set $
   Bit.Sum
      (Bit.Sum (bit9x9 k i) (bit9x9 k j))
      (Bit.Sum (bit9x9 i j) (bit9x9 k (div i 3 + 3 * div j 3)))

bitAssigns :: [Assign Mask]
bitAssigns = liftM3 bitAssign [1..9] [0..8] [0..8]


type BitVector = BitSet.Set Integer

bitVectorAssigns :: [Assign BitVector]
bitVectorAssigns = ESC.bitVectorFromSetAssigns assigns


format :: [((Int, Int), Int)] -> String
format =
   unlines . map (intersperse ' ') . sliceVertical 9 . Array.elems .
   fmap (\n -> toEnum $ n + fromEnum '0') .
   array ((0,0),(8,8))


exampleHawiki1 :: [String]
exampleHawiki1 =
   "    6  8 " :
   " 2       " :
   "  1      " :
   " 7    1 2" :
   "5   3    " :
   "      4  " :
   "  42 1   " :
   "3  7  6  " :
   "       5 " :
   []

stateFromString ::
   (ESC.Set set) =>
   [Assign set] -> [String] -> ESC.State ((Int, Int), Int) set
stateFromString asgns css =
   foldl (flip ESC.updateState) (ESC.initState asgns) $
   do let asnMap = foldMap (\asn -> Map.singleton (ESC.label asn) asn) asgns
      (i,cs) <- zip [0..] css
      (j,c)  <- zip [0..] cs
      guard $ c/=' '
      return $
         Map.findWithDefault
            (error "coordinates not available")
            ((i,j), fromEnum c - fromEnum '0') asnMap


main, mainAll, mainSolve, mainBit, mainBitVector :: IO ()
mainAll =
   mapM_ (putStrLn . format) $ ESC.partitions bitAssigns

mainSolve =
   mapM_ (putStrLn . format) $ ESC.search $
   stateFromString assigns exampleHawiki1

mainBit =
   mapM_ (putStrLn . format) $ ESC.search $
   stateFromString bitAssigns exampleHawiki1

mainBitVector =
   mapM_ (putStrLn . format) $ ESC.search $
   stateFromString bitVectorAssigns exampleHawiki1

main = mainBitVector