haskell sudoku

gistfile1.hs

{-# LANGUAGE BangPatterns #-}
import Data.Bits
import Data.List
import qualified Data.Vector.Unboxed as UV
type Grid = UV.Vector PossSet
type PossSet = Int
type Index = Int
type Value = Int
data Region = Row Int | Col Int | Sq Int deriving(Show)
line = "0 0 12 0 0 0 21 0 0 11 0 0 0 7 0 0 0 0 3 17 0 0 9 0 24 0 0 0 0 17 0 0 18 0 0 11 0 0 0 0 0 22 0 0 0 1 13 20 0 0 4 1 2 8 9 0 0 0 3 0 0 0 24 20 0 0 6 0 0 0 0 0 0 22 11 21 22 24 23 0 0 4 10 5 0 0 0 9 18 1 0 0 15 0 0 3 8 0 0 0 11 0 0 7 0 24 6 0 2 23 17 4 0 0 12 0 0 0 0 0 0 0 15 0 0 0 0 0 0 0 17 9 21 0 0 0 15 0 19 0 0 0 0 18 0 0 0 0 16 14 0 0 0 5 0 4 22 11 0 10 0 0 0 16 17 0 0 12 0 1 13 9 25 0 8 0 0 6 0 3 0 18 1 0 0 0 0 14 21 7 0 0 0 9 23 19 0 0 2 0 0 9 0 17 8 0 15 25 0 0 12 0 0 4 0 0 2 0 0 11 20 0 21 0 0 0 13 7 0 0 23 3 0 0 0 0 0 20 0 0 0 0 0 0 10 0 18 0 4 22 13 0 18 0 5 2 0 0 0 0 0 0 4 0 0 3 0 0 0 8 0 1 0 7 23 0 0 0 16 23 0 0 7 0 0 1 25 0 0 5 0 0 0 0 0 24 0 14 0 0 0 0 0 11 25 0 0 12 0 0 0 0 0 23 21 20 0 14 4 0 0 0 0 0 0 8 12 20 19 0 0 0 0 23 0 0 0 0 0 11 24 0 0 0 6 0 0 17 10 0 14 2 0 0 0 0 8 0 19 25 6 16 0 3 9 11 0 5 0 12 0 0 0 20 15 12 17 0 0 0 0 0 5 0 21 18 0 6 0 0 2 9 0 0 24 4 0 10 0 20 2 0 0 1 0 0 0 0 0 3 0 0 0 0 25 19 0 0 21 22 16 0 0 24 0 20 0 0 24 16 0 10 0 0 0 0 0 17 1 0 0 0 23 0 5 18 25 0 3 0 0 8 0 0 14 25 17 0 0 0 24 9 19 5 0 6 0 0 20 0 0 11 23 1 0 0 0 11 25 6 20 1 0 0 7 0 0 16 14 0 0 0 0 10 15 17 12 0 0 21 22 23 0 0 0 21 0 16 0 0 0 8 0 0 18 7 0 24 0 0 0 14 13 0 17 0 7 0 15 0 0 20 0 0 6 0 24 0 2 14 13 0 0 11 3 0 0 5 0 25 3 21 0 10 0 7 25 14 15 19 0 0 0 9 0 22 0 6 0 0 2 0 0 0 0 9 0 0 0 0 18 5 0 0 0 23 19 15 0 10 0 0 1 0 0 0 0 11 0 0 0 16 0 0 20 3 0 24 13 4 0 0 0 17 0 0 0 0 0 25 0 21 12 15 0"
grid = toGrid $ words line

foldlInt :: (a -> b -> Int -> a) -> a -> [b] -> a
foldlInt f init seq = fst $ foldl' (\(agg, i) next -> (f agg next i, i+1)) (init, 0) seq

sideLen = 25
sideLenQuarter = 5

allBits :: Grid -> PossSet
allBits g = (shift 1 $ UV.length g) - 1
        
setCell :: Grid -> Index -> Value -> Grid
setCell g i v = eliminate g i $ (allBits g) `clearBit` v

solved :: PossSet -> Bool
solved p = popCount p == 1

solvedG :: Grid -> Index -> Bool
solvedG g i = solved (g UV.! i)

toGrid :: [String] -> Grid
toGrid words = foldlInt reduce empty arr
    where
        arr = map read words :: [Int]
        bits = (shift 1 sideLen) - 1
        empty = UV.replicate (length arr) bits
        reduce g x i = if x==0 then g else setCell g i (x-1)

brothers :: Grid -> Index -> [Index]
brothers g i = [x | r<-intersections g i, x<-cells r, x /= i]
          
cells :: Region -> [Index]
cells (Row n) = take sideLen (drop (sideLen * n) cells')
cells (Col n) = take sideLen (drop (sideLen * n + sideLen*sideLen) cells')
cells (Sq n) = take sideLen (drop (sideLen * n + sideLen*sideLen*2) cells')

offset :: Region -> Int
offset (Row n) = n
offset (Col n) = 25+n
offset (Sq n) = 50+n

cells' :: [Int]
cells' = [
  0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,
  25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,
  50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,
  75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
  100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,
  125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,
  150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,
  175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,
  200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,
  225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,
  250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,
  275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,
  300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,
  325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,
  350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,
  375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,
  400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,
  425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,
  450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,
  475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,
  500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,
  525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,
  550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,
  575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,
  600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,
  0,25,50,75,100,125,150,175,200,225,250,275,300,325,350,375,400,425,450,475,500,525,550,575,600,
  1,26,51,76,101,126,151,176,201,226,251,276,301,326,351,376,401,426,451,476,501,526,551,576,601,
  2,27,52,77,102,127,152,177,202,227,252,277,302,327,352,377,402,427,452,477,502,527,552,577,602,
  3,28,53,78,103,128,153,178,203,228,253,278,303,328,353,378,403,428,453,478,503,528,553,578,603,
  4,29,54,79,104,129,154,179,204,229,254,279,304,329,354,379,404,429,454,479,504,529,554,579,604,
  5,30,55,80,105,130,155,180,205,230,255,280,305,330,355,380,405,430,455,480,505,530,555,580,605,
  6,31,56,81,106,131,156,181,206,231,256,281,306,331,356,381,406,431,456,481,506,531,556,581,606,
  7,32,57,82,107,132,157,182,207,232,257,282,307,332,357,382,407,432,457,482,507,532,557,582,607,
  8,33,58,83,108,133,158,183,208,233,258,283,308,333,358,383,408,433,458,483,508,533,558,583,608,
  9,34,59,84,109,134,159,184,209,234,259,284,309,334,359,384,409,434,459,484,509,534,559,584,609,
  10,35,60,85,110,135,160,185,210,235,260,285,310,335,360,385,410,435,460,485,510,535,560,585,610,
  11,36,61,86,111,136,161,186,211,236,261,286,311,336,361,386,411,436,461,486,511,536,561,586,611,
  12,37,62,87,112,137,162,187,212,237,262,287,312,337,362,387,412,437,462,487,512,537,562,587,612,
  13,38,63,88,113,138,163,188,213,238,263,288,313,338,363,388,413,438,463,488,513,538,563,588,613,
  14,39,64,89,114,139,164,189,214,239,264,289,314,339,364,389,414,439,464,489,514,539,564,589,614,
  15,40,65,90,115,140,165,190,215,240,265,290,315,340,365,390,415,440,465,490,515,540,565,590,615,
  16,41,66,91,116,141,166,191,216,241,266,291,316,341,366,391,416,441,466,491,516,541,566,591,616,
  17,42,67,92,117,142,167,192,217,242,267,292,317,342,367,392,417,442,467,492,517,542,567,592,617,
  18,43,68,93,118,143,168,193,218,243,268,293,318,343,368,393,418,443,468,493,518,543,568,593,618,
  19,44,69,94,119,144,169,194,219,244,269,294,319,344,369,394,419,444,469,494,519,544,569,594,619,
  20,45,70,95,120,145,170,195,220,245,270,295,320,345,370,395,420,445,470,495,520,545,570,595,620,
  21,46,71,96,121,146,171,196,221,246,271,296,321,346,371,396,421,446,471,496,521,546,571,596,621,
  22,47,72,97,122,147,172,197,222,247,272,297,322,347,372,397,422,447,472,497,522,547,572,597,622,
  23,48,73,98,123,148,173,198,223,248,273,298,323,348,373,398,423,448,473,498,523,548,573,598,623,
  24,49,74,99,124,149,174,199,224,249,274,299,324,349,374,399,424,449,474,499,524,549,574,599,624,
  0,1,2,3,4,25,26,27,28,29,50,51,52,53,54,75,76,77,78,79,100,101,102,103,104,
  5,6,7,8,9,30,31,32,33,34,55,56,57,58,59,80,81,82,83,84,105,106,107,108,109,
  10,11,12,13,14,35,36,37,38,39,60,61,62,63,64,85,86,87,88,89,110,111,112,113,114,
  15,16,17,18,19,40,41,42,43,44,65,66,67,68,69,90,91,92,93,94,115,116,117,118,119,
  20,21,22,23,24,45,46,47,48,49,70,71,72,73,74,95,96,97,98,99,120,121,122,123,124,
  125,126,127,128,129,150,151,152,153,154,175,176,177,178,179,200,201,202,203,204,225,226,227,228,229,
  130,131,132,133,134,155,156,157,158,159,180,181,182,183,184,205,206,207,208,209,230,231,232,233,234,
  135,136,137,138,139,160,161,162,163,164,185,186,187,188,189,210,211,212,213,214,235,236,237,238,239,
  140,141,142,143,144,165,166,167,168,169,190,191,192,193,194,215,216,217,218,219,240,241,242,243,244,
  145,146,147,148,149,170,171,172,173,174,195,196,197,198,199,220,221,222,223,224,245,246,247,248,249,
  250,251,252,253,254,275,276,277,278,279,300,301,302,303,304,325,326,327,328,329,350,351,352,353,354,
  255,256,257,258,259,280,281,282,283,284,305,306,307,308,309,330,331,332,333,334,355,356,357,358,359,
  260,261,262,263,264,285,286,287,288,289,310,311,312,313,314,335,336,337,338,339,360,361,362,363,364,
  265,266,267,268,269,290,291,292,293,294,315,316,317,318,319,340,341,342,343,344,365,366,367,368,369,
  270,271,272,273,274,295,296,297,298,299,320,321,322,323,324,345,346,347,348,349,370,371,372,373,374,
  375,376,377,378,379,400,401,402,403,404,425,426,427,428,429,450,451,452,453,454,475,476,477,478,479,
  380,381,382,383,384,405,406,407,408,409,430,431,432,433,434,455,456,457,458,459,480,481,482,483,484,
  385,386,387,388,389,410,411,412,413,414,435,436,437,438,439,460,461,462,463,464,485,486,487,488,489,
  390,391,392,393,394,415,416,417,418,419,440,441,442,443,444,465,466,467,468,469,490,491,492,493,494,
  395,396,397,398,399,420,421,422,423,424,445,446,447,448,449,470,471,472,473,474,495,496,497,498,499,
  500,501,502,503,504,525,526,527,528,529,550,551,552,553,554,575,576,577,578,579,600,601,602,603,604,
  505,506,507,508,509,530,531,532,533,534,555,556,557,558,559,580,581,582,583,584,605,606,607,608,609,
  510,511,512,513,514,535,536,537,538,539,560,561,562,563,564,585,586,587,588,589,610,611,612,613,614,
  515,516,517,518,519,540,541,542,543,544,565,566,567,568,569,590,591,592,593,594,615,616,617,618,619,
  520,521,522,523,524,545,546,547,548,549,570,571,572,573,574,595,596,597,598,599,620,621,622,623,624]


    
intersections :: Grid -> Index -> [Region]
intersections g i = 
    let 
        row = i `div` sideLen
        col = i `mod` sideLen
    in [Row row, Col col, Sq $ row `div` sideLenQuarter * sideLenQuarter + col `div` sideLenQuarter]
    
allRegions :: Grid -> [Region]
allRegions g = concat [[Row i, Col i, Sq i] | i <- [0..sideLen - 1]]

containsVal :: PossSet -> Value -> Bool
containsVal poss value = poss .&. (shift 1 value) /= 0

eliminate :: Grid -> Index -> PossSet -> Grid
eliminate g i elim = 
    let p1 = g UV.! i
        p2 = p1 .&. complement elim
        g2 = g UV.// [(i, p2)]
    in  if p2 == p1 then g else if (solved p2) then (isolate g2 i) else g2
              
isolate :: Grid -> Index -> Grid
isolate g i = 
    let 
        p = g UV.! i
        bros = brothers g i
        newVal bro = (g UV.! bro) .&. complement p
        updates = map (\bro -> (bro, newVal bro)) bros
        g2 = g UV.// updates
        newIsos = filter (\bro -> (not (solved (g UV.! bro))) && (solved (newVal bro))) bros
    in  foldl' isolate g2 newIsos

lr :: Grid -> Grid
lr = lr2 $ UV.fromList cells'

lr2 :: UV.Vector Int -> Grid -> Grid
lr2 !cells'' !g = foldl' lr' g $ allRegions g
    where
      lr' :: Grid -> Region -> Grid
      lr' !gxx !region = foldl' (lr'' region) gxx [0..sideLen - 1]
          where
              lr'' :: Region -> Grid -> Value -> Grid
              lr'' !region !gx !value = if lone then setCell gx index value else gx
                where
                  !start = sideLen * (offset region)
                  !end = start + sideLen
                  !p = 1 `shift` value
                  loop :: Int -> Int -> Int
                  loop !index !current
                    | index < end    = if ((gx UV.! i) .&. p /= 0) then (if (current /= (-1)) then (-1) else (loop (index+1) i)) else (loop (index+1) current)
                    | otherwise      = current
                    where i = cells'' UV.! index
                  index = loop start (-1)
                  lone = index /= (-1)
                  
si :: Grid -> Grid
si g = foldl' (\g (i,r) -> si' g r $ g UV.! i) g [(i,r) | i <- [0..UV.length g - 1], r <- intersections g i]
    where
      si' :: Grid -> Region -> PossSet -> Grid
      si' g region poss = if length limitedToPoss == popCount poss then g' else g
          where
            indexes = cells region
            isLimitedToPoss i = g UV.! i .|. poss == poss
            (limitedToPoss, notLimitedToPoss) = partition isLimitedToPoss indexes
            g' = foldl' (\g i -> eliminate g i poss) g notLimitedToPoss

isConsistent :: Grid -> Bool            
isConsistent g = not $ UV.elem 0 g

te :: (Grid -> Grid) -> Grid -> Grid
te f g = foldl' te' g $ filter (not . solvedG g) [0..UV.length g - 1]
    where
        te' :: Grid -> Index -> Grid
        te' g i = foldl' te'' g $ filter (testBit poss) [0..sideLen - 1]
            where 
                poss = g UV.! i
                te'' :: Grid -> Value -> Grid
                te'' g v = if isConsistent clone then g else g'
                    where 
                        clone = f $ setCell g i v
                        g' = eliminate g i $ bit v
      

run :: Eq a => (a -> a) -> a -> a
run f a = if a == b then a else run f b
    where b = f a
    
runAll :: Eq a => [(a -> a)] -> a -> a
runAll fs = if null fs then id else run $ (head fs) . runAll (tail fs)

runSi :: Grid -> Grid
runSi = runAll [si, lr]

teLr = te $ run lr
runTe = runAll [teLr, si, lr]

elimCount :: Grid -> Int
elimCount g = UV.foldl' (\i p -> i - popCount p) 15625 g

x = runSi grid
y = runTe grid

main = do
    print y
    print $ elimCount y