{- |
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 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
forall a. HasCallStack => [a] -> a
head ([[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

-- | 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]
    ]
  )