{- |
Description: Nonograms
Copyright: Copyright (C) 2021 Yoo Chung
License: GPL-3.0-or-later
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]
    ]
  )