content: {-# LANGUAGE QuasiQuotes #-}
  
  module AOC.Common.OCR (
      parseLetters
    , parseLettersSafe
    , parseLettersAll
    , contiguousShapes
    ) where
  
  import           AOC.Common
  import           Control.Lens
  import           Control.Monad
  import           Data.Bifunctor
  import           Data.Foldable
  import           Data.List.NonEmpty (NonEmpty(..))
  import           Data.Map           (Map)
  import           Data.Semigroup
  import           Data.Set           (Set)
  import           Data.Set.NonEmpty  (NESet)
  import           Linear
  import           Text.Heredoc       (here)
  import qualified Control.Foldl      as F
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Map           as M
  import qualified Data.Map.NonEmpty  as NEM
  import qualified Data.Set           as S
  import qualified Data.Set.NonEmpty  as NES
  
  -- | The set of unconnected shapes, indexed by their original center of
  -- mass
  contiguousShapes :: Set Point -> Map (V2 Double) (NESet Point)
  contiguousShapes s0 = M.fromList
      [ (com, NES.map (subtract topCorner) s)
      | NES.IsNonEmpty s <- S.toList . S.map flood $ s0
      , let com            = F.fold ((lmap . fmap) fromIntegral F.mean) s
            V2 topCorner _ = boundingBox s
      ]
    where
      flood = floodFill (S.fromList . filter (`S.member` s0) . fullNeighbs)
            . S.singleton
  
  -- | The set of unconnected shapes, sorted against some function on their
  -- original center of masses
  contiguousShapesBy
      :: Ord a
      => (V2 Double -> a)
      -> Set Point
      -> [NESet Point]
  contiguousShapesBy f = toList . M.mapKeys f . contiguousShapes
  
  parseLettersAll
      :: Set Point
      -> NonEmpty String
  parseLettersAll letters = snd $ NEM.findMin attempts
    where
      NEM.IsNonEmpty attempts = M.fromListWith (<>)
          [ (score :: Int, res :| [])
          | refl <- [id, over _x negate]
          , rots <- [id, perp, negate, negate . perp]
          , let ls = S.map (rots . refl) letters
                (Sum score, res) = tryMe ls
          ]
      tryMe = traverse (\c -> maybe (Sum 1, '?') (Sum 0,) . M.lookup c $ letterMap)
            . contiguousShapesBy (view _x)
  
  
  parseLetters
      :: Set Point
      -> String
  parseLetters = NE.head . parseLettersAll
  
  parseLettersSafe
      :: Set Point
      -> Maybe String
  parseLettersSafe pts = x <$ guard (NES.size (NES.fromList ls) == 1)
    where
      ls@(x :| _) = parseLettersAll pts
  
  
  -- | A map of a set of "on" points (for a 4x6 grid) to the letter they
  -- represent
  letterMap :: Map (NESet Point) Char
  letterMap = M.fromList
            . uncurry (zipWith (flip (,)))
            . second ( contiguousShapesBy (view _x)
                     . M.keysSet
                     . parseAsciiMap (guard . (== '#'))
                     )
            $ rawLetterforms
  
  rawLetterforms :: (String, String)
  rawLetterforms = ("ABCEFGHJKLPRUYZ", drop 1 [here|
  .##..###...##..####.####..##..#..#...##.#..#.#....###..###..#..#.#...#.####
  #..#.#..#.#..#.#....#....#..#.#..#....#.#.#..#....#..#.#..#.#..#.#...#....#
  #..#.###..#....###..###..#....####....#.##...#....#..#.#..#.#..#..#.#....#.
  ####.#..#.#....#....#....#.##.#..#....#.#.#..#....###..###..#..#...#....#..
  #..#.#..#.#..#.#....#....#..#.#..#.#..#.#.#..#....#....#.#..#..#...#...#...
  #..#.###...##..####.#.....###.#..#..##..#..#.####.#....#..#..##....#...####
  |])
  