set-cover-0.0.6: example/Nonogram.hs

{-
* <https://en.wikipedia.org/wiki/Nonogram>
* <https://de.wikipedia.org/wiki/Datei:Paint_by_numbers_Animation.gif>

The solver works but is pretty slow
although the Combinatoric set formulation minimizes the need to guess.
-}
module Main where

import qualified Nonogram.Example as Example
import qualified Nonogram.Encoding.Combinatoric as Combinatoric
import qualified Nonogram.Encoding.BlackWhite as BlackWhite
import qualified Nonogram.Encoding.Plug as Plug
import qualified Nonogram.Encoding.Naive as Naive
import Nonogram.Base (Color(White, Black))

import qualified Math.SetCover.Exact as ESC

import qualified Data.Map as Map; import Data.Map (Map)
import qualified Data.Set as Set; import Data.Set (Set)
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.HT as ListHT
import Data.Foldable (foldMap)
import Data.NonEmpty ((!:))


decode :: [[Int]] -> [[Int]] -> [Set (Int, Int)]
decode rows columns =
   map Set.unions $
   case 01::Int of
      00 -> ESC.partitions $
               Combinatoric.bitVectorAssigns (length rows) (length columns) $
               Combinatoric.assigns rows columns
      01 -> ESC.partitions $
               Combinatoric.bitAssigns $ Combinatoric.assigns rows columns
      02 -> ESC.partitions $
               Combinatoric.intSetAssigns (length rows) (length columns) $
               Combinatoric.assigns rows columns
      03 -> ESC.partitions $ Combinatoric.assigns rows columns
      10 -> ESC.partitions $
               BlackWhite.bitAssigns rows columns $
               BlackWhite.assigns rows columns
      11 -> ESC.partitions $ BlackWhite.assigns rows columns
      20 -> ESC.partitions $ Plug.assigns rows columns
      _  -> ESC.partitions $ Naive.assigns rows columns


format :: Int -> Int -> Set (Int, Int) -> String
format rows columns set =
   unlines $
   ListHT.outerProduct
      (\r c -> if Set.member (r,c) set then 'X' else '.')
      (take rows [0..])
      (take columns [0..])

formatBW :: Int -> Int -> Map (Int, Int) Color -> String
formatBW rows columns set =
   unlines $
   ListHT.outerProduct
      (\r c ->
         case Map.lookup (r,c) set of
            Nothing -> '_'
            Just Black -> 'X'
            Just White -> '.')
      (take rows [0..])
      (take columns [0..])

besidesMany :: Int -> [String] -> String
besidesMany space =
   let besides blockL blockR =
         let width = NonEmpty.maximum (0 !: map length blockL) + space
         in  zipWith (\l r -> ListHT.padRight ' ' width l ++ r) blockL blockR
   in  unlines . foldr1 besides . map lines

testSimple :: ([[Int]], [[Int]]) -> IO ()
testSimple (rows, columns) = do
   let assigns = Naive.assigns rows columns
   mapM_ (print . ESC.labeledSet) assigns
   putStrLn "set union:"
   print $ foldMap ESC.labeledSet assigns
   mapM_ (putStrLn . format (length rows) (length columns) . Set.unions) $
      ESC.partitions assigns

decodeImage :: ([[Int]], [[Int]]) -> IO ()
decodeImage (rows, columns) =
   mapM_ (putStrLn . format (length rows) (length columns)) $
   decode rows columns

testImage :: IO ()
testImage = decodeImage $ Example.encodeStrings Example.letterP

evolve :: ([[Int]], [[Int]]) -> IO ()
evolve (rows, columns) =
   let formatIntermediate state =
          (show $ length $ ESC.availableSubsets state) ++ '\n' :
          (formatBW (length rows) (length columns) .
           Map.unionsWith (error "conflicting colors") .
           map ESC.label . ESC.usedSubsets $ state)
   in  mapM_ (putStrLn . besidesMany 2 . map formatIntermediate) $
       fst $ ListHT.breakAfter (all (ESC.null . ESC.freeElements)) $
       iterate (concatMap ESC.step)
         [ESC.initState $ Combinatoric.bitAssigns $
          Combinatoric.assignsBW rows columns]

main :: IO ()
main = evolve Example.soccerEnc