{- |
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 Maybe [[Maybe Bool]] 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  = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
printNonogramSolution (Just [[Bool]]
p) = [[Int]] -> [[Int]] -> Maybe [[Maybe Bool]] -> IO ()
printNonogram [[Int]]
rows [[Int]]
columns (Maybe [[Maybe Bool]] -> IO ()) -> Maybe [[Maybe Bool]] -> IO ()
forall a b. (a -> b) -> a -> 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]) -> [[Bool]] -> [[Maybe Bool]]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Maybe Bool) -> [Bool] -> [Maybe Bool]
forall a b. (a -> b) -> [a] -> [b]
map Bool -> Maybe Bool
forall a. a -> Maybe a
Just) [[Bool]]
p
where rows :: [[Int]]
rows = [[Bool]] -> [[Int]]
getLengths [[Bool]]
p
columns :: [[Int]]
columns = [[Bool]] -> [[Int]]
getLengths ([[Bool]] -> [[Int]]) -> [[Bool]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$[[Bool]] -> [[Bool]] forall a. [[a]] -> [[a]] transpose [[Bool]] p getLengths :: [[Bool]] -> [[Int]] getLengths :: [[Bool]] -> [[Int]] getLengths [] = [] getLengths [[Bool]] picture = ([Bool] -> [Int]) -> [[Bool]] -> [[Int]] forall a b. (a -> b) -> [a] -> [b] map (([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]) -> ([Bool] -> [[Bool]]) -> [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 isOccupied ([[Bool]] -> [[Bool]]) -> ([Bool] -> [[Bool]]) -> [Bool] -> [[Bool]] forall b c a. (b -> c) -> (a -> b) -> a -> c . [Bool] -> [[Bool]] forall a. Eq a => [a] -> [[a]] group) [[Bool]] picture where isOccupied :: [Bool] -> Bool isOccupied (Bool v:[Bool] _) = Bool v isOccupied [] = Bool False -- | 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 (Maybe [[Maybe Bool]] -> IO ()) -> Maybe [[Maybe Bool]] -> IO () forall a b. (a -> b) -> a -> 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
$Int -> [Maybe Bool] -> [[Maybe Bool]] forall a. Int -> a -> [a] replicate ([[Int]] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [[Int]] rows) ([Maybe Bool] -> [[Maybe Bool]]) -> [Maybe Bool] -> [[Maybe Bool]] forall a b. (a -> b) -> a -> b$ Int -> Maybe Bool -> [Maybe Bool]
forall a. Int -> a -> [a]
replicate ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
columns) Maybe Bool
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 (Maybe [[Maybe Bool]] -> IO ()) -> Maybe [[Maybe Bool]] -> IO ()
forall a b. (a -> b) -> a -> b
$[[Maybe Bool]] -> Maybe [[Maybe Bool]] forall a. a -> Maybe a Just [[Maybe Bool]] cells printNonogram [[Int]] _ [[Int]] _ Maybe [[Maybe Bool]] _ = IO () forall a. HasCallStack => a undefined printRowCells :: [Maybe Bool] -> IO () printRowCells :: [Maybe Bool] -> IO () printRowCells = (Maybe Bool -> IO ()) -> [Maybe Bool] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> IO () putStr (String -> IO ()) -> (Maybe Bool -> String) -> Maybe Bool -> IO () 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 = (Int -> IO ()) -> [Int] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (String -> IO () putStr (String -> IO ()) -> (Int -> String) -> Int -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char ' ':) (String -> String) -> (Int -> String) -> Int -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> String forall a. Show a => a -> String show) printColumns :: [[Int]] -> IO () printColumns :: [[Int]] -> IO () printColumns [[Int]] columns = (String -> IO ()) -> [String] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ String -> IO () 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 (Char -> IO ()) -> t Char -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (\Char x -> String -> IO () putStr (String -> IO ()) -> String -> IO () forall a b. (a -> b) -> a -> b$ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
x]) t Char
l
String -> IO ()
putStrLn String
""

formatColumns :: [[Int]] -> [String]
formatColumns :: [[Int]] -> [String]
formatColumns [[Int]]
columns = [String] -> [String]
forall a. [[a]] -> [[a]]
transpose [String]
texts'
where texts :: [String]
texts = ([Int] -> String) -> [[Int]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unwords ([String] -> String) -> ([Int] -> [String]) -> [Int] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show) [[Int]]
columns
-- make all strings the same length
texts' :: [String]
texts' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
t -> String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Char
' ') [String]
texts
l :: Int
l = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$(String -> Int) -> [String] -> [Int] forall a b. (a -> b) -> [a] -> [b] map String -> Int forall a. [a] -> Int 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]
]
)