{- |
Description: Nonograms
Copyright: Copyright (C) 2023 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P98" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P98 (nonogram) where

import           Control.Monad.State.Lazy
import           Data.Array               (Array, listArray, (!), (//))
import qualified Data.Array               as Array
import           Data.Foldable            (foldlM)
import           Data.List                (group, sortOn)
import           Data.Maybe               (fromJust, isJust, isNothing)
import           System.Random

-- | Solve a nonogram.
nonogram :: [[Int]]  -- ^ Lengths of occupied cells in each row
         -> [[Int]]  -- ^ Lengths of occupied cells in each column
         -> Maybe [[Bool]]  -- ^ Solution to the puzzle, if it exists
nonogram :: [[Int]] -> [[Int]] -> Maybe [[Bool]]
nonogram [[Int]]
rows [[Int]]
columns = (Maybe [[Bool]], StdGen) -> Maybe [[Bool]]
forall a b. (a, b) -> a
fst ((Maybe [[Bool]], StdGen) -> Maybe [[Bool]])
-> (Maybe [[Bool]], StdGen) -> Maybe [[Bool]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]] -> StdGen -> (Maybe [[Bool]], StdGen)
forall g.
RandomGen g =>
[[Int]] -> [[Int]] -> g -> (Maybe [[Bool]], g)
randomNonogram [[Int]]
rows [[Int]]
columns (StdGen -> (Maybe [[Bool]], StdGen))
-> StdGen -> (Maybe [[Bool]], StdGen)
forall a b. (a -> b) -> a -> b
$ Int -> StdGen
mkStdGen Int
11111

-- | A nonogram solver, which uses the given source of randomness if it needs to make any guesses.
randomNonogram :: RandomGen g
               => [[Int]]  -- ^ Lengths of occupied cells in each row
               -> [[Int]]  -- ^ Lengths of occupied cells in each column
               -> g        -- ^ Random generator
               -> (Maybe [[Bool]], g)  -- ^ Solution to the puzzle, if it exists, and random generator
randomNonogram :: forall g.
RandomGen g =>
[[Int]] -> [[Int]] -> g -> (Maybe [[Bool]], g)
randomNonogram [[Int]]
rows [[Int]]
columns g
gen = (Maybe Bitmap -> Maybe [[Bool]]
toList Maybe Bitmap
solution, g
gen')
  where (Maybe Bitmap
solution, g
gen') = [[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
fillBitmap [[Int]]
rows [[Int]]
columns [Int
1..[[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
rows] [Int
1..[[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
columns] Bitmap
blank g
gen
        blank :: Bitmap
blank = Int -> Int -> Bitmap
blankBitmap ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
rows) ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
columns)

-- | Stores the partially built bitmap.
-- Positions with 'Just' values are those that definitely have a certain bit.
type Bitmap = Array (Int,Int) (Maybe Bool)

-- | Stores a partially built line.
-- May be a row or a column in the partially built bitmap.
type Line = Array Int (Maybe Bool)

blankBitmap :: Int -> Int -> Bitmap
blankBitmap :: Int -> Int -> Bitmap
blankBitmap Int
rows Int
columns = ((Int, Int), (Int, Int)) -> [Maybe Bool] -> Bitmap
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray ((Int
1,Int
1), (Int
rows,Int
columns)) ([Maybe Bool] -> Bitmap) -> [Maybe Bool] -> Bitmap
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> [Maybe Bool]
forall a. a -> [a]
repeat Maybe Bool
forall a. Maybe a
Nothing

toList :: Maybe Bitmap -> Maybe [[Bool]]
toList :: Maybe Bitmap -> Maybe [[Bool]]
toList Maybe Bitmap
Nothing = Maybe [[Bool]]
forall a. Maybe a
Nothing
toList (Just Bitmap
picture) = [[Bool]] -> Maybe [[Bool]]
forall a. a -> Maybe a
Just ([[Bool]] -> Maybe [[Bool]]) -> [[Bool]] -> Maybe [[Bool]]
forall a b. (a -> b) -> a -> b
$ (Int -> [Bool]) -> [Int] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
r -> (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
c -> Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
r,Int
c)) [Int
1..Int
columns]) [Int
1..Int
rows]
  where rows :: Int
rows = Bitmap -> Int
getRowSize Bitmap
picture
        columns :: Int
columns = Bitmap -> Int
getColumnSize Bitmap
picture

getRowSize :: Bitmap -> Int
getRowSize :: Bitmap -> Int
getRowSize Bitmap
picture = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int), (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd (((Int, Int), (Int, Int)) -> (Int, Int))
-> ((Int, Int), (Int, Int)) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Bitmap -> ((Int, Int), (Int, Int))
forall i e. Array i e -> (i, i)
Array.bounds Bitmap
picture

getColumnSize :: Bitmap -> Int
getColumnSize :: Bitmap -> Int
getColumnSize Bitmap
picture = (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int), (Int, Int)) -> (Int, Int)
forall a b. (a, b) -> b
snd (((Int, Int), (Int, Int)) -> (Int, Int))
-> ((Int, Int), (Int, Int)) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Bitmap -> ((Int, Int), (Int, Int))
forall i e. Array i e -> (i, i)
Array.bounds Bitmap
picture

-- | The high level body for solving a nonogram.
-- It basically goes as:
--
-- 1. Tries to determine as many definite bits as it can.
--
-- 2. If all bits are definite, we have a solution.
--    If a contradictory bit appears, there is no solution.
--
-- 3. Repeat the search for definite bits until no more definite bits are found.
--    If there are still indefinite bits, pretend that one of them is definite and go back to 1.
fillBitmap :: RandomGen g => [[Int]] -> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
fillBitmap :: forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
fillBitmap [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
picture g
gen
  | (Maybe Bool -> Bool) -> Bitmap -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Bitmap
picture      = case Bitmap -> [[Int]] -> [[Int]] -> Bool
isConsistentWithPuzzle Bitmap
picture [[Int]]
rows [[Int]]
columns of
                                Bool
True  -> (Bitmap -> Maybe Bitmap
forall a. a -> Maybe a
Just Bitmap
picture, g
gen)
                                Bool
False -> (Maybe Bitmap
forall a. Maybe a
Nothing, g
gen)
  | Maybe Bitmap -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Bitmap
maybePicture' = (Maybe Bitmap
forall a. Maybe a
Nothing, g
gen)
  | Bitmap
picture Bitmap -> Bitmap -> Bool
forall a. Eq a => a -> a -> Bool
== Bitmap
picture'     = [[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
guess [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
picture g
gen
  | Bool
otherwise               = [[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
fillBitmap [[Int]]
rows [[Int]]
columns [Int]
remainingRows' [Int]
remainingColumns' Bitmap
picture' g
gen
  where maybePicture' :: Maybe Bitmap
maybePicture' = do
          Bitmap
p <- [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillRows [[Int]]
rows [Int]
remainingRows Bitmap
picture
          [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillColumns [[Int]]
columns [Int]
remainingColumns Bitmap
p
        picture' :: Bitmap
picture' = Maybe Bitmap -> Bitmap
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Bitmap
maybePicture'
        remainingRows' :: [Int]
remainingRows' = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Int -> Bool
isIncompleteRow [Int]
remainingRows
        remainingColumns' :: [Int]
remainingColumns' = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Int -> Bool
isIncompleteColumn [Int]
remainingColumns
        isIncompleteRow :: Int -> Bool
isIncompleteRow Int
r = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
c -> Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bitmap
picture' Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
r,Int
c)) [Int
1..Bitmap -> Int
getColumnSize Bitmap
picture']
        isIncompleteColumn :: Int -> Bool
isIncompleteColumn Int
c = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
r -> Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bitmap
picture' Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
r,Int
c)) [Int
1..Bitmap -> Int
getRowSize Bitmap
picture']

isConsistentWithPuzzle :: Bitmap -> [[Int]] -> [[Int]] -> Bool
isConsistentWithPuzzle :: Bitmap -> [[Int]] -> [[Int]] -> Bool
isConsistentWithPuzzle Bitmap
picture [[Int]]
rows [[Int]]
columns = Bool
withRows Bool -> Bool -> Bool
&& Bool
withColumns
  where withRows :: Bool
withRows = [[Int]]
rows [[Int]] -> [[Int]] -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int (Maybe Bool) -> [Int]
forall {i}. Array i (Maybe Bool) -> [Int]
lengths (Array Int (Maybe Bool) -> [Int])
-> (Int -> Array Int (Maybe Bool)) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bitmap -> Int -> Array Int (Maybe Bool)
getRow Bitmap
picture) [Int
1..Bitmap -> Int
getRowSize Bitmap
picture]
        withColumns :: Bool
withColumns = [[Int]]
columns [[Int]] -> [[Int]] -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int (Maybe Bool) -> [Int]
forall {i}. Array i (Maybe Bool) -> [Int]
lengths (Array Int (Maybe Bool) -> [Int])
-> (Int -> Array Int (Maybe Bool)) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bitmap -> Int -> Array Int (Maybe Bool)
getColumn Bitmap
picture) [Int
1..Bitmap -> Int
getColumnSize Bitmap
picture]
        lengths :: Array i (Maybe Bool) -> [Int]
lengths = ([Bool] -> Int) -> [[Bool]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Bool]] -> [Int])
-> (Array i (Maybe Bool) -> [[Bool]])
-> Array i (Maybe Bool)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> Bool) -> [[Bool]] -> [[Bool]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Bool] -> Bool
occupied ([[Bool]] -> [[Bool]])
-> (Array i (Maybe Bool) -> [[Bool]])
-> Array i (Maybe Bool)
-> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [[Bool]]
forall a. Eq a => [a] -> [[a]]
group ([Bool] -> [[Bool]])
-> (Array i (Maybe Bool) -> [Bool])
-> Array i (Maybe Bool)
-> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Bool) -> [Maybe Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe Bool] -> [Bool])
-> (Array i (Maybe Bool) -> [Maybe Bool])
-> Array i (Maybe Bool)
-> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array i (Maybe Bool) -> [Maybe Bool]
forall i e. Array i e -> [e]
Array.elems
        occupied :: [Bool] -> Bool
occupied (Bool
v:[Bool]
_) = Bool
v
        occupied [] = Bool
False

fillRows :: [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillRows :: [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillRows [[Int]]
rows [Int]
remainingRows Bitmap
p = (Bitmap -> Int -> Maybe Bitmap) -> Bitmap -> [Int] -> Maybe Bitmap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\Bitmap
p' Int
i -> Bitmap -> Int -> [Int] -> Maybe Bitmap
fill Bitmap
p' Int
i ([Int] -> Maybe Bitmap) -> [Int] -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ [[Int]]
rows [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Bitmap
p [Int]
remainingRows
  where fill :: Bitmap -> Int -> [Int] -> Maybe Bitmap
fill Bitmap
picture Int
row [Int]
lengths = Bitmap -> Int -> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
replaceRow Bitmap
picture Int
row (Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap)
-> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ [Int] -> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
fillLine [Int]
lengths (Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool)))
-> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ Bitmap -> Int -> Array Int (Maybe Bool)
getRow Bitmap
picture Int
row

fillColumns :: [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillColumns :: [[Int]] -> [Int] -> Bitmap -> Maybe Bitmap
fillColumns [[Int]]
columns [Int]
remainingColumns Bitmap
p = (Bitmap -> Int -> Maybe Bitmap) -> Bitmap -> [Int] -> Maybe Bitmap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\Bitmap
p' Int
i -> Bitmap -> Int -> [Int] -> Maybe Bitmap
fill Bitmap
p' Int
i ([Int] -> Maybe Bitmap) -> [Int] -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ [[Int]]
columns [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Bitmap
p [Int]
remainingColumns
  where fill :: Bitmap -> Int -> [Int] -> Maybe Bitmap
fill Bitmap
picture Int
column [Int]
lengths = Bitmap -> Int -> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
replaceColumn Bitmap
picture Int
column (Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap)
-> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ [Int] -> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
fillLine [Int]
lengths (Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool)))
-> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ Bitmap -> Int -> Array Int (Maybe Bool)
getColumn Bitmap
picture Int
column

getRow :: Bitmap -> Int -> Line
getRow :: Bitmap -> Int -> Array Int (Maybe Bool)
getRow Bitmap
picture Int
row = (Int, Int) -> [Maybe Bool] -> Array Int (Maybe Bool)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,[Maybe Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Bool]
cells) [Maybe Bool]
cells
  where cells :: [Maybe Bool]
cells = [Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
row,Int
column) | Int
column <- [Int
1..Bitmap -> Int
getColumnSize Bitmap
picture]]

getColumn :: Bitmap -> Int -> Line
getColumn :: Bitmap -> Int -> Array Int (Maybe Bool)
getColumn Bitmap
picture Int
column = (Int, Int) -> [Maybe Bool] -> Array Int (Maybe Bool)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,[Maybe Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Bool]
cells) [Maybe Bool]
cells
  where cells :: [Maybe Bool]
cells = [Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
row,Int
column) | Int
row <- [Int
1..Bitmap -> Int
getRowSize Bitmap
picture]]

replaceRow :: Bitmap -> Int -> Maybe Line -> Maybe Bitmap
replaceRow :: Bitmap -> Int -> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
replaceRow Bitmap
_ Int
_ Maybe (Array Int (Maybe Bool))
Nothing = Maybe Bitmap
forall a. Maybe a
Nothing
replaceRow Bitmap
picture Int
row (Just Array Int (Maybe Bool)
line) = Bitmap -> Maybe Bitmap
forall a. a -> Maybe a
Just (Bitmap -> Maybe Bitmap) -> Bitmap -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> [((Int, Int), Maybe Bool)] -> Bitmap
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [((Int, Int), Maybe Bool)]
cells
  where cells :: [((Int, Int), Maybe Bool)]
cells = [((Int
row,Int
column), Array Int (Maybe Bool)
line Array Int (Maybe Bool) -> Int -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! Int
column) | Int
column <- [Int
1..Bitmap -> Int
getColumnSize Bitmap
picture]]

replaceColumn :: Bitmap -> Int -> Maybe Line -> Maybe Bitmap
replaceColumn :: Bitmap -> Int -> Maybe (Array Int (Maybe Bool)) -> Maybe Bitmap
replaceColumn Bitmap
_ Int
_ Maybe (Array Int (Maybe Bool))
Nothing = Maybe Bitmap
forall a. Maybe a
Nothing
replaceColumn Bitmap
picture Int
column (Just Array Int (Maybe Bool)
line) = Bitmap -> Maybe Bitmap
forall a. a -> Maybe a
Just (Bitmap -> Maybe Bitmap) -> Bitmap -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> [((Int, Int), Maybe Bool)] -> Bitmap
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [((Int, Int), Maybe Bool)]
cells
  where cells :: [((Int, Int), Maybe Bool)]
cells = [((Int
row,Int
column), Array Int (Maybe Bool)
line Array Int (Maybe Bool) -> Int -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! Int
row) | Int
row <- [Int
1..Bitmap -> Int
getRowSize Bitmap
picture]]

-- | When there are no more bits that can be inferred to be definite,
-- pick a bit at random and see what happens if we pretend it's definite.
guess :: RandomGen g => [[Int]] -> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
guess :: forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
guess [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
picture =
  State g (Maybe Bitmap) -> g -> (Maybe Bitmap, g)
forall s a. State s a -> s -> (a, s)
runState ([[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> State g (Maybe Bitmap)
forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> State g (Maybe Bitmap)
guess' [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
picture)

guess' :: RandomGen g => [[Int]] -> [[Int]] -> [Int] -> [Int] -> Bitmap -> State g (Maybe Bitmap)
guess' :: forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> State g (Maybe Bitmap)
guess' [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
picture = do
  [Int]
tags <- State g [Int]
forall g a. (RandomGen g, Random a) => State g [a]
rnds  -- Random numbers used for random tie breaking during sorting.
  Bool
value <- State g Bool
forall g a. (RandomGen g, Random a) => State g a
rnd  -- Definite value to try first
  let ranked :: [((Int, Int), Int)]
ranked = (((Int, Int), Int) -> (Int, Int))
-> [((Int, Int), Int)] -> [((Int, Int), Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Bitmap -> ((Int, Int), Int) -> (Int, Int)
countIndefiniteNeighbors Bitmap
picture) ([((Int, Int), Int)] -> [((Int, Int), Int)])
-> [((Int, Int), Int)] -> [((Int, Int), Int)]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [Int] -> [((Int, Int), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int)]
candidates [Int]
tags
  case [((Int, Int), Int)]
ranked of
    [] -> Maybe Bitmap -> State g (Maybe Bitmap)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bitmap
forall a. Maybe a
Nothing
    (((Int, Int)
candidate, Int
_) : [((Int, Int), Int)]
_) -> do
      Maybe Bitmap
picture' <- Bitmap -> State g (Maybe Bitmap)
forall {s} {m :: * -> *}.
(MonadState s m, RandomGen s) =>
Bitmap -> m (Maybe Bitmap)
fill (Bitmap -> State g (Maybe Bitmap))
-> Bitmap -> State g (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> [((Int, Int), Maybe Bool)] -> Bitmap
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [((Int, Int)
candidate, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
value)]
      case Maybe Bitmap
picture' of
        Maybe Bitmap
Nothing -> Bitmap -> State g (Maybe Bitmap)
forall {s} {m :: * -> *}.
(MonadState s m, RandomGen s) =>
Bitmap -> m (Maybe Bitmap)
fill (Bitmap -> State g (Maybe Bitmap))
-> Bitmap -> State g (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> [((Int, Int), Maybe Bool)] -> Bitmap
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [((Int, Int)
candidate, Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
value)]
        Maybe Bitmap
_       -> Maybe Bitmap -> State g (Maybe Bitmap)
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bitmap
picture'
  where candidates :: [(Int, Int)]
candidates = ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int, Int)
p -> Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int, Int)
p) [(Int
r,Int
c) | Int
r <- [Int]
remainingRows, Int
c <- [Int]
remainingColumns]
        fill :: Bitmap -> m (Maybe Bitmap)
fill Bitmap
p = (s -> (Maybe Bitmap, s)) -> m (Maybe Bitmap)
forall a. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((s -> (Maybe Bitmap, s)) -> m (Maybe Bitmap))
-> (s -> (Maybe Bitmap, s)) -> m (Maybe Bitmap)
forall a b. (a -> b) -> a -> b
$ [[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> s -> (Maybe Bitmap, s)
forall g.
RandomGen g =>
[[Int]]
-> [[Int]] -> [Int] -> [Int] -> Bitmap -> g -> (Maybe Bitmap, g)
fillBitmap [[Int]]
rows [[Int]]
columns [Int]
remainingRows [Int]
remainingColumns Bitmap
p

-- | For sorting positions so that those that have more definite values in the same row and column come first.
-- This will hopefully make it more likely to cause a contradiction earlier if there is no solution
-- when we set a definite value for a position, i.e., prunes the search space much more.
countIndefiniteNeighbors :: Bitmap -> ((Int,Int),Int) -> (Int,Int)
countIndefiniteNeighbors :: Bitmap -> ((Int, Int), Int) -> (Int, Int)
countIndefiniteNeighbors Bitmap
picture ((Int
row,Int
column),Int
rx) = (Int
rowCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
columnCount,Int
rx)
  where rowCount :: Int
rowCount = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Maybe Bool -> Int
forall {a} {a}. Num a => Maybe a -> a
toInt (Maybe Bool -> Int) -> Maybe Bool -> Int
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
row, Int
c) | Int
c <- [Int
1..Bitmap -> Int
getColumnSize Bitmap
picture]]
        columnCount :: Int
columnCount = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Maybe Bool -> Int
forall {a} {a}. Num a => Maybe a -> a
toInt (Maybe Bool -> Int) -> Maybe Bool -> Int
forall a b. (a -> b) -> a -> b
$ Bitmap
picture Bitmap -> (Int, Int) -> Maybe Bool
forall i e. Ix i => Array i e -> i -> e
! (Int
r, Int
column) | Int
r <- [Int
1..Bitmap -> Int
getRowSize Bitmap
picture]]
        toInt :: Maybe a -> a
toInt Maybe a
Nothing = a
1
        toInt Maybe a
_       = a
0

rnd :: (RandomGen g, Random a) => State g a
rnd :: forall g a. (RandomGen g, Random a) => State g a
rnd = (g -> (a, g)) -> StateT g Identity a
forall a. (g -> (a, g)) -> StateT g Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state g -> (a, g)
forall g. RandomGen g => g -> (a, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random

rnds :: (RandomGen g, Random a) => State g [a]
rnds :: forall g a. (RandomGen g, Random a) => State g [a]
rnds = do g
gen <- (g -> (g, g)) -> StateT g Identity g
forall a. (g -> (a, g)) -> StateT g Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state g -> (g, g)
forall g. RandomGen g => g -> (g, g)
split
          [a] -> State g [a]
forall a. a -> StateT g Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> State g [a]) -> [a] -> State g [a]
forall a b. (a -> b) -> a -> b
$ g -> [a]
forall g. RandomGen g => g -> [a]
forall a g. (Random a, RandomGen g) => g -> [a]
randoms g
gen

-- The definitions above deals with the scaffolding for solving the problem.
-- What comes below is the heart of the logic for inferring bits in the bitmap.

-- | Fill the line with more definite bits, if any.
fillLine :: [Int] -> Line -> Maybe Line
fillLine :: [Int] -> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
fillLine [Int]
xs Array Int (Maybe Bool)
line
  | [Int] -> [Maybe Bool] -> Bool
isConsistent [Int]
xs [Maybe Bool]
line'    = Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a. a -> Maybe a
Just (Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool)))
-> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ [Maybe Bool] -> Array Int (Maybe Bool)
forall {e}. [e] -> Array Int e
toArray [Maybe Bool]
line'
  | [[Maybe Bool]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Maybe Bool]]
possibleLines       = Maybe (Array Int (Maybe Bool))
forall a. Maybe a
Nothing
  | Bool
isDone Bool -> Bool -> Bool
&& Bool
isInconsistent = Maybe (Array Int (Maybe Bool))
forall a. Maybe a
Nothing
  | Bool
otherwise                = Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a. a -> Maybe a
Just (Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool)))
-> Array Int (Maybe Bool) -> Maybe (Array Int (Maybe Bool))
forall a b. (a -> b) -> a -> b
$ [Maybe Bool] -> Array Int (Maybe Bool)
forall {e}. [e] -> Array Int e
toArray [Maybe Bool]
incorporated
  where
    bits :: [Maybe Bool]
bits = Array Int (Maybe Bool) -> [Maybe Bool]
forall i e. Array i e -> [e]
Array.elems Array Int (Maybe Bool)
line
    toArray :: [e] -> Array Int e
toArray [e]
l = (Int, Int) -> [e] -> Array Int e
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,[e] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [e]
l) [e]
l
    line' :: [Maybe Bool]
line' = (Maybe Bool -> Maybe Bool) -> [Maybe Bool] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\Maybe Bool
x -> case Maybe Bool
x of Maybe Bool
Nothing -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False; Maybe Bool
_ -> Maybe Bool
x) [Maybe Bool]
bits

    -- From bits that are the same for all possible lines,
    -- infer that they are definite.
    definiteBits :: [Maybe Bool]
definiteBits = ([Maybe Bool] -> [Maybe Bool] -> [Maybe Bool])
-> [[Maybe Bool]] -> [Maybe Bool]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
merge [[Maybe Bool]]
possibleLines
    possibleLines :: [[Maybe Bool]]
possibleLines = ([Maybe Bool] -> Bool) -> [[Maybe Bool]] -> [[Maybe Bool]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Int] -> [Maybe Bool] -> Bool
isConsistent [Int]
xs) ([[Maybe Bool]] -> [[Maybe Bool]])
-> [[Maybe Bool]] -> [[Maybe Bool]]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Maybe Bool] -> [[Maybe Bool]]
fillLine' Int
1 [Int]
xs [Maybe Bool]
bits
    merge :: [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
merge = (Maybe Bool -> Maybe Bool -> Maybe Bool)
-> [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Bool -> Maybe Bool -> Maybe Bool
forall {a}. Eq a => Maybe a -> Maybe a -> Maybe a
combine
    combine :: Maybe a -> Maybe a -> Maybe a
combine (Just a
u) (Just a
v) | a
u a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v    = a -> Maybe a
forall a. a -> Maybe a
Just a
u
                              | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
    combine Maybe a
_ Maybe a
_ = Maybe a
forall a. Maybe a
Nothing

    -- For incorporating definite bits into the line.
    incorporate :: [Maybe a] -> [Maybe a] -> [Maybe a]
incorporate = (Maybe a -> Maybe a -> Maybe a)
-> [Maybe a] -> [Maybe a] -> [Maybe a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe a -> Maybe a -> Maybe a
forall {a}. Maybe a -> Maybe a -> Maybe a
set
    set :: Maybe a -> Maybe a -> Maybe a
set Maybe a
Nothing Maybe a
v  = Maybe a
v
    set Maybe a
u Maybe a
Nothing  = Maybe a
u
    set Maybe a
_ (Just a
u) = a -> Maybe a
forall a. a -> Maybe a
Just a
u

    incorporated :: [Maybe Bool]
incorporated = [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
forall {a}. [Maybe a] -> [Maybe a] -> [Maybe a]
incorporate [Maybe Bool]
bits [Maybe Bool]
definiteBits
    isDone :: Bool
isDone = (Maybe Bool -> Bool) -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust [Maybe Bool]
incorporated
    isInconsistent :: Bool
isInconsistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> [Maybe Bool] -> Bool
isConsistent [Int]
xs [Maybe Bool]
incorporated

isConsistent :: [Int] -> [Maybe Bool] -> Bool
isConsistent :: [Int] -> [Maybe Bool] -> Bool
isConsistent [] [Maybe Bool]
line = (Maybe Bool -> Bool) -> [Maybe Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False ==) [Maybe Bool]
line
isConsistent [Int]
xs [Maybe Bool]
line = [Int]
xs [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
xs'
  where xs' :: [Int]
xs' = ([Maybe Bool] -> Int) -> [[Maybe Bool]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Maybe Bool]] -> [Int]) -> [[Maybe Bool]] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([Maybe Bool] -> Bool) -> [[Maybe Bool]] -> [[Maybe Bool]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Maybe Bool] -> Bool
occupied ([[Maybe Bool]] -> [[Maybe Bool]])
-> [[Maybe Bool]] -> [[Maybe Bool]]
forall a b. (a -> b) -> a -> b
$ [Maybe Bool] -> [[Maybe Bool]]
forall a. Eq a => [a] -> [[a]]
group [Maybe Bool]
line
        occupied :: [Maybe Bool] -> Bool
occupied (Just Bool
v : [Maybe Bool]
_) = Bool
v
        occupied [Maybe Bool]
_ = Bool
False

fillLine' :: Int -> [Int] -> [Maybe Bool] -> [[Maybe Bool]]
fillLine' :: Int -> [Int] -> [Maybe Bool] -> [[Maybe Bool]]
fillLine' Int
_ [] [Maybe Bool]
line         = [[Maybe Bool]
line]
fillLine' Int
start (Int
x:[Int]
xs) [Maybe Bool]
line = (Int -> [[Maybe Bool]]) -> [Int] -> [[Maybe Bool]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Maybe Bool] -> [Int] -> Int -> Int -> [[Maybe Bool]]
fillSegment [Maybe Bool]
line [Int]
xs Int
x) [Int]
positions
  where positions :: [Int]
positions = [Int
start..[Maybe Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Bool]
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]

-- | With the given length and position,
-- place a segment with consecutive 'True's followed by a 'False'.
-- If this would result in a contradiction, 'Nothing' is returned.
fillSegment :: [Maybe Bool] -> [Int] -> Int -> Int -> [[Maybe Bool]]
fillSegment :: [Maybe Bool] -> [Int] -> Int -> Int -> [[Maybe Bool]]
fillSegment [Maybe Bool]
line [Int]
xs Int
len Int
pos
  | Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Maybe Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Bool]
line = []
  | (Maybe (Maybe Bool) -> Bool) -> [Maybe (Maybe Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe (Maybe Bool) -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe (Maybe Bool)]
line'     = []
  | Bool
otherwise               = Int -> [Int] -> [Maybe Bool] -> [[Maybe Bool]]
fillLine' (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Int]
xs ([Maybe Bool] -> [[Maybe Bool]]) -> [Maybe Bool] -> [[Maybe Bool]]
forall a b. (a -> b) -> a -> b
$ (Maybe (Maybe Bool) -> Maybe Bool)
-> [Maybe (Maybe Bool)] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Maybe Bool) -> Maybe Bool
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (Maybe Bool)]
line'
  where segment :: [Maybe Bool]
segment = Int -> Maybe Bool -> [Maybe Bool]
forall a. Int -> a -> [a]
replicate (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Maybe Bool
forall a. Maybe a
Nothing [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
forall a. [a] -> [a] -> [a]
++ Int -> Maybe Bool -> [Maybe Bool]
forall a. Int -> a -> [a]
replicate Int
len (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
forall a. [a] -> [a] -> [a]
++ [Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False] [Maybe Bool] -> [Maybe Bool] -> [Maybe Bool]
forall a. [a] -> [a] -> [a]
++ Maybe Bool -> [Maybe Bool]
forall a. a -> [a]
repeat Maybe Bool
forall a. Maybe a
Nothing
        line' :: [Maybe (Maybe Bool)]
line' = (Maybe Bool -> Maybe Bool -> Maybe (Maybe Bool))
-> [Maybe Bool] -> [Maybe Bool] -> [Maybe (Maybe Bool)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Bool -> Maybe Bool -> Maybe (Maybe Bool)
combineCell [Maybe Bool]
line [Maybe Bool]
segment

combineCell :: Maybe Bool -> Maybe Bool -> Maybe (Maybe Bool)
combineCell :: Maybe Bool -> Maybe Bool -> Maybe (Maybe Bool)
combineCell Maybe Bool
Nothing Maybe Bool
Nothing = Maybe Bool -> Maybe (Maybe Bool)
forall a. a -> Maybe a
Just Maybe Bool
forall a. Maybe a
Nothing
combineCell Maybe Bool
b Maybe Bool
Nothing = Maybe Bool -> Maybe (Maybe Bool)
forall a. a -> Maybe a
Just Maybe Bool
b
combineCell Maybe Bool
Nothing Maybe Bool
b = Maybe Bool -> Maybe (Maybe Bool)
forall a. a -> Maybe a
Just Maybe Bool
b
combineCell (Just Bool
a) (Just Bool
b) | Bool
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b    = Maybe Bool -> Maybe (Maybe Bool)
forall a. a -> Maybe a
Just (Maybe Bool -> Maybe (Maybe Bool))
-> Maybe Bool -> Maybe (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
a
                              | Bool
otherwise = Maybe (Maybe Bool)
forall a. Maybe a
Nothing