{- |
Description: Nonograms
Maintainer: dev@chungyc.org

Part of Ninety-Nine Haskell "Problems".  Some solutions are in "Solutions.P98".
-}
module Problems.P98 (nonogram, printNonogramPuzzle, printNonogramSolution, nonogramPuzzle) where

import           Data.List     (group, transpose)
import qualified Solutions.P98 as Solution

{- |
[Nonograms](https://en.wikipedia.org/wiki/Nonogram) are picture logic puzzles invented in 1987,
spreading from Japan to across the world.  They look like this:

@
□ □ □ □ □ □ □ □  3
□ □ □ □ □ □ □ □  2 1
□ □ □ □ □ □ □ □  3 2
□ □ □ □ □ □ □ □  2 2
□ □ □ □ □ □ □ □  6
□ □ □ □ □ □ □ □  1 5
□ □ □ □ □ □ □ □  6
□ □ □ □ □ □ □ □  1
□ □ □ □ □ □ □ □  2

1 3 1 7 5 3 4 3

2 1 5 1
@

Essentially, each row and column of a rectangular bitmap is annotated
with the respective lengths of its distinct strings of occupied cells.
The person who solves the puzzle must complete the bitmap given only these lengths.
Published puzzles are larger than this example, e.g., $$25 \times 20$$,
and apparently always have unique solutions.

Try to solve the $$25 \times 25$$ puzzle in 'nonogramPuzzle'.

=== Examples

>>> :{
printNonogramSolution $nonogram [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]] [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]] :} ■ ■ ■ 3 ■ ■ ■ 2 1 ■ ■ ■ ■ ■ 3 2 ■ ■ ■ ■ 2 2 ■ ■ ■ ■ ■ ■ 6 ■ ■ ■ ■ ■ ■ 1 5 ■ ■ ■ ■ ■ ■ 6 ■ 1 ■ ■ 2 <BLANKLINE> 1 3 1 7 5 3 4 3 <BLANKLINE> 2 1 5 1 === __Hint__ If there is a string of occupied cells with length 9 in a row of 10 cells, can we infer which cells in the row /must/ be occupied? -} 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]] -> [[Int]] -> Maybe [[Bool]] Solution.nonogram {- | Print out a nonogram puzzle. >>> :{ printNonogramPuzzle [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]] [[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]] :} □ □ □ □ □ □ □ □ 3 □ □ □ □ □ □ □ □ 2 1 □ □ □ □ □ □ □ □ 3 2 □ □ □ □ □ □ □ □ 2 2 □ □ □ □ □ □ □ □ 6 □ □ □ □ □ □ □ □ 1 5 □ □ □ □ □ □ □ □ 6 □ □ □ □ □ □ □ □ 1 □ □ □ □ □ □ □ □ 2 <BLANKLINE> 1 3 1 7 5 3 4 3 <BLANKLINE> 2 1 5 1 -} printNonogramPuzzle :: [[Int]] -> [[Int]] -> IO () printNonogramPuzzle :: [[Int]] -> [[Int]] -> IO () printNonogramPuzzle [[Int]] rows [[Int]] columns = [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO () printNonogram [[Int]] rows [[Int]] columns forall a. Maybe a Nothing {- | Print out a nonogram solution. >>> :{ printNonogramSolution$
nonogram [[3],[2,1],[3,2],[2,2],[6],[1,5],[6],[1],[2]]
[[1,2],[3,1],[1,5],[7,1],[5],[3],[4],[3]]
:}
■ ■ ■          3
■ ■   ■          2 1
■ ■ ■     ■ ■  3 2
■ ■     ■ ■  2 2
■ ■ ■ ■ ■ ■  6
■   ■ ■ ■ ■ ■    1 5
■ ■ ■ ■ ■ ■      6
■        1
■ ■        2
<BLANKLINE>
1 3 1 7 5 3 4 3
<BLANKLINE>
2 1 5 1
-}
printNonogramSolution :: Maybe [[Bool]] -> IO ()
printNonogramSolution :: Maybe [[Bool]] -> IO ()
printNonogramSolution Maybe [[Bool]]
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
printNonogramSolution (Just [[Bool]]
p) = [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO ()
printNonogram [[Int]]
rows [[Int]]
columns forall a b. (a -> b) -> a -> b
$forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just) [[Bool]]
p
where rows :: [[Int]]
rows = [[Bool]] -> [[Int]]
getLengths [[Bool]]
p
columns :: [[Int]]
columns = [[Bool]] -> [[Int]]
getLengths forall a b. (a -> b) -> a -> b
$forall a. [[a]] -> [[a]] transpose [[Bool]] p getLengths :: [[Bool]] -> [[Int]] getLengths :: [[Bool]] -> [[Int]] getLengths [] = [] getLengths [[Bool]] picture = forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map forall (t :: * -> *) a. Foldable t => t a -> Int length forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter forall a. [a] -> a head forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Eq a => [a] -> [[a]] group) [[Bool]] picture -- | Print out a nonogram puzzle or solution. printNonogram :: [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO () printNonogram :: [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO () printNonogram [[Int]] rows [[Int]] columns Maybe [[Maybe Bool]] Nothing = [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO () printNonogram [[Int]] rows [[Int]] columns forall a b. (a -> b) -> a -> b$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$forall a. Int -> a -> [a] replicate (forall (t :: * -> *) a. Foldable t => t a -> Int length [[Int]] rows) forall a b. (a -> b) -> a -> b$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
columns) forall a. Maybe a
Nothing
printNonogram [] [[Int]]
columns (Just []) = do
String -> IO ()
putStrLn String
""
[[Int]] -> IO ()
printColumns [[Int]]
columns
printNonogram ([Int]
r:[[Int]]
rows) [[Int]]
columns (Just ([Maybe Bool]
c:[[Maybe Bool]]
cells)) = do
[Maybe Bool] -> IO ()
printRowCells [Maybe Bool]
c
String -> IO ()
putStr String
" "
[Int] -> IO ()
printRowLengths [Int]
r
String -> IO ()
putStrLn String
""
[[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO ()
printNonogram [[Int]]
rows [[Int]]
columns forall a b. (a -> b) -> a -> b
$forall a. a -> Maybe a Just [[Maybe Bool]] cells printNonogram [[Int]] _ [[Int]] _ Maybe [[Maybe Bool]] _ = forall a. HasCallStack => a undefined printRowCells :: [Maybe Bool] -> IO () printRowCells :: [Maybe Bool] -> IO () printRowCells = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> IO () putStr forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe Bool -> String format) where format :: Maybe Bool -> String format Maybe Bool Nothing = String " □" format (Just Bool False) = String " " format (Just Bool True) = String " ■" printRowLengths :: [Int] -> IO () printRowLengths :: [Int] -> IO () printRowLengths = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> IO () putStr forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char ' ':) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Show a => a -> String show) printColumns :: [[Int]] -> IO () printColumns :: [[Int]] -> IO () printColumns [[Int]] columns = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall {t :: * -> *}. Foldable t => t Char -> IO () printLine [String] ls where ls :: [String] ls = [[Int]] -> [String] formatColumns [[Int]] columns printLine :: t Char -> IO () printLine t Char l = do forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (\Char x -> String -> IO () putStr forall a b. (a -> b) -> a -> b$ Char
' 'forall a. a -> [a] -> [a]
:[Char
x]) t Char
l
String -> IO ()
putStrLn String
""

formatColumns :: [[Int]] -> [String]
formatColumns :: [[Int]] -> [String]
formatColumns [[Int]]
columns = forall a. [[a]] -> [[a]]
transpose [String]
texts'
where texts :: [String]
texts = forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show) [[Int]]
columns
-- make all strings the same length
texts' :: [String]
texts' = forall a b. (a -> b) -> [a] -> [b]
map (\String
t -> String
t forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
l forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Char
' ') [String]
texts
l :: Int
l = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$forall a b. (a -> b) -> [a] -> [b] map forall (t :: * -> *) a. Foldable t => t a -> Int length [String] texts -- | A nonogram puzzle of size $$25 \times 25$$. -- -- >>> printNonogramSolution$ let (rs, cs) = nonogramPuzzle in nonogram rs cs
-- ...
nonogramPuzzle :: ([[Int]],[[Int]])
nonogramPuzzle :: ([[Int]], [[Int]])
nonogramPuzzle =
-- From https://nonograms-katana.com/, which states "All puzzles are free".
-- This is the 25x25 Pegasus puzzle.
( [ [Int
11], [Int
11], [Int
10], [Int
9,Int
1], [Int
8,Int
3], [Int
8,Int
5], [Int
7,Int
7], [Int
7,Int
9], [Int
5,Int
5,Int
2], [Int
9], [Int
13], [Int
16], [Int
2,Int
14], [Int
2,Int
14]
, [Int
3,Int
14], [Int
2,Int
15], [Int
2,Int
4,Int
5], [Int
3,Int
4,Int
3], [Int
2,Int
5,Int
1,Int
1], [Int
2,Int
2,Int
1,Int
1], [Int
1,Int
2,Int
2,Int
1], [Int
1,Int
2,Int
2], [Int
1,Int
1], [Int
2,Int
2], [Int
2,Int
2]
]
, [ [Int
1,Int
2], [Int
1,Int
5], [Int
2,Int
6], [Int
2,Int
4], [Int
3,Int
1], [Int
3,Int
5,Int
6], [Int
4,Int
10,Int
2], [Int
6,Int
9,Int
1], [Int
8,Int
11], [Int
9,Int
12], [Int
9,Int
6,Int
3]
, [Int
15,Int
2], [Int
15,Int
1], [Int
14], [Int
5,Int
7], [Int
8], [Int
10], [Int
11], [Int
12,Int
1], [Int
6,Int
6], [Int
4,Int
2,Int
1], [Int
5,Int
5], [Int
3], [Int
3], [Int
2]
]
)