diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +Changelog +========= + +Version 0.1.0.0 +--------------- + +*November 24, 2020* + + + +* Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# advent-of-code-ocr + +"OCR" letter recognition for [Advent of Code][aoc] puzzles, compatible with all +puzzles from 2015 to 2019. Also comes with a handy command line utility to +parse the ASCII art directly from stdin: + +[aoc]: https://adventofcode.com + +``` +$ cat abc.txt +.##..###...##. +#..#.#..#.#..# +#..#.###..#... +####.#..#.#... +#..#.#..#.#..# +#..#.###...##. +$ cat abc.txt | advent-of-code-ocr +ABC +``` + +## Installation + +To use as a library, add *advent-of-code-ocr* as a hackage dependency like you +would any other. + +To use as an executable: + +```bash +# using stack +stack install advent-of-code-ocr +# using cabal +cabal install advent-of-code-ocr +# from source +git clone https://github.com/mstksg/advent-of-code-ocr +cd advent-of-code-ocr +cabal install # or stack install +``` + +## Compatibility + +Should be compatible with all challenges from 2015 to 2019. However, I have +only tested it with: + + +* 2016 Day 8 +* 2018 Day 10 +* 2019 Day 8 +* 2019 Day 11 + +And it is possible I have missed some. If you notice any I am missing, please +let me know! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/advent-of-code-ocr.cabal b/advent-of-code-ocr.cabal new file mode 100644 --- /dev/null +++ b/advent-of-code-ocr.cabal @@ -0,0 +1,108 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 0805d230cfe0698678c80d553c5e6fddf779fa9b6dc4a8ce5afee7dd03dd3c74 + +name: advent-of-code-ocr +version: 0.1.0.0 +synopsis: Parse Advent of Code ASCII art letters +description: "OCR" letter recognition for + puzzles, compatible with all puzzles from 2015 to 2019. Also comes with a + handy command line utility to parse the ASCII art directly from stdin. +category: Text +homepage: https://github.com/mstksg/advent-of-code-ocr#readme +bug-reports: https://github.com/mstksg/advent-of-code-ocr/issues +author: Justin Le +maintainer: justin@jle.im +copyright: 2020 Justin Le +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/mstksg/advent-of-code-ocr + +library + exposed-modules: + Advent.OCR + Advent.OCR.Internal + other-modules: + Advent.OCR.LetterMap + hs-source-dirs: + src + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , containers + , data-default-class + , heredoc + , template-haskell + , th-lift + , th-lift-instances + default-language: Haskell2010 + +executable advent-of-code-ocr + main-is: ocr.hs + other-modules: + Paths_advent_of_code_ocr + hs-source-dirs: + app + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + advent-of-code-ocr + , base >=4.7 && <5 + , containers + , data-default-class + , heredoc + , optparse-applicative + , template-haskell + , th-lift + , th-lift-instances + default-language: Haskell2010 + +test-suite advent-of-code-ocr-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_advent_of_code_ocr + hs-source-dirs: + test + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + advent-of-code-ocr + , base >=4.7 && <5 + , containers + , data-default-class + , heredoc + , hspec + , template-haskell + , th-lift + , th-lift-instances + default-language: Haskell2010 + +benchmark advent-of-code-ocr-bench + type: exitcode-stdio-1.0 + main-is: bench.hs + other-modules: + Paths_advent_of_code_ocr + hs-source-dirs: + bench + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O2 + build-depends: + advent-of-code-ocr + , base >=4.7 && <5 + , containers + , criterion + , data-default-class + , heredoc + , template-haskell + , th-lift + , th-lift-instances + default-language: Haskell2010 diff --git a/app/ocr.hs b/app/ocr.hs new file mode 100644 --- /dev/null +++ b/app/ocr.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +import Advent.OCR +import Options.Applicative +import System.Exit +import System.IO +import qualified Data.Set as S + +data Opts = Opts + { oChars :: S.Set Char + } + deriving Show + +parseOpts :: Parser Opts +parseOpts = Opts <$> + option (S.fromList <$> str) + ( long "chars" + <> short 'c' + <> help "characters to treat as \"on\"/included" + <> value (S.singleton '#') + <> showDefaultWith S.toList + <> metavar "CHARS" + ) + +main :: IO () +main = do + Opts{..} <- execParser $ + info (parseOpts <**> helper) + ( fullDesc + <> progDesc "Parse an ASCII image into its letters." + <> header "advent-of-code-orc - Advent of Code ASCII parser" + ) + inp <- getContents + case asciiMapToLetters oChars inp of + Nothing -> do + hPutStrLn stderr "No valid parse" + exitFailure + Just res -> putStrLn res diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE QuasiQuotes #-} + +import Advent.OCR +import Criterion.Main +import Data.Set (Set) +import Text.Heredoc +import qualified Data.Set as S + +main :: IO () +main = defaultMainWith defaultConfig [ + bench "small font" $ nf parseLetters smallFont + , bench "large font" $ nf parseLetters bigFont + ] + +smallFont :: Set (Int, Int) +smallFont = parseAsciiMap (S.singleton '#') $ drop 1 [here| +####...##.#..#.###..#..#..##..###..#... +...#....#.#..#.#..#.#.#..#..#.#..#.#... +..#.....#.####.#..#.##...#....#..#.#... +.#......#.#..#.###..#.#..#....###..#... +#....#..#.#..#.#.#..#.#..#..#.#....#... +####..##..#..#.#..#.#..#..##..#....#### +|] + +bigFont :: Set (Int, Int) +bigFont = parseAsciiMap (S.singleton '#') $ drop 1 [here| +..##....#....#..######..#.......#........####.....##....#..... +.#..#...#....#.......#..#.......#.......#....#...#..#...#..... +#....#..#....#.......#..#.......#.......#.......#....#..#..... +#....#..#....#......#...#.......#.......#.......#....#..#..... +#....#..######.....#....#.......#.......#.......#....#..#..... +######..#....#....#.....#.......#.......#.......######..#..... +#....#..#....#...#......#.......#.......#.......#....#..#..... +#....#..#....#..#.......#.......#.......#.......#....#..#..... +#....#..#....#..#.......#.......#.......#....#..#....#..#..... +#....#..#....#..######..######..######...####...#....#..###### +|] diff --git a/src/Advent/OCR.hs b/src/Advent/OCR.hs new file mode 100644 --- /dev/null +++ b/src/Advent/OCR.hs @@ -0,0 +1,153 @@ +-- | +-- Module : Advent.OCR +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Library to parse "ASCII Art" letters from puzzles. Compatible with all puzzles from 2015 to 2019. +-- +module Advent.OCR ( + -- * Parse + parseLetters + , parseLettersWith + , parseLettersEither + , unsafeParseLetters + , parseAsciiMap + , asciiMapToLetters + -- * Letter Map + , LetterMap + , defaultLetterMap + -- ** Custom Letter Map + , parseLetters' + , parseLettersWith' + , parseLettersEither' + , unsafeParseLetters' + , asciiMapToLetters' + ) where + +import Advent.OCR.Internal +import Data.Bifunctor +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S + +-- | A version of 'parseLettersWith'' accepting a custom 'LetterMap' +-- letterform database. +parseLettersWith' + :: LetterMap -- ^ database of letterforms + -> (a -> Int) -- ^ get X + -> (a -> Int) -- ^ get Y + -> Set a + -> Maybe String +parseLettersWith' lm f g = parseLettersV2 lm . S.map (\x -> V2 (f x) (g x)) + +-- | A version of 'parseLetters' that takes a set of any type of value, as +-- long as you provide functions to access the X and Y coordinates. +parseLettersWith + :: (a -> Int) -- ^ get X + -> (a -> Int) -- ^ get Y + -> Set a + -> Maybe String +parseLettersWith = parseLettersWith' defaultLetterMap + +-- | A version of 'parseLetters'' accepting a custom 'LetterMap' letterform +-- database. +parseLetters' + :: LetterMap -- ^ database of letterforms + -> Set (Int, Int) -- ^ set of points + -> Maybe String -- ^ result, with unknown letters replaced with "?" +parseLetters' lm = parseLettersV2 lm . S.mapMonotonic (uncurry V2) + +-- | The go-to default: given a set of point coordinates, parse it into +-- the string it represents. Should be compatible with any Advent of Code +-- challenge from 2015 to 2019. +-- +-- @ +-- 'parseLetters' 'defaultLetterMap' myPoints +-- +-- -- or, using Data.Default +-- 'parseLetters' 'Data.Default.Class.def' myPoints +-- @ +-- +-- A 'Nothing' means that there were no recognized letters found. A 'Just' +-- means that least 50% of letter forms are recognized. Unrecognized +-- characters will be replaced with "?"; for more information, use +-- 'parseLettersEither'. +-- +-- This function is robust to changes in orientation or flipping, but will +-- be fastest if the coordinates are oriented with (0,0) on the upper left +-- corner. However, because of this, it might return the wrong answer if +-- your coordinates are /not/ oriented this way and your result is +-- symmetrical: it'll always prioritize the interpretaion against (0,0) +-- upper-left orientation first. +parseLetters + :: Set (Int, Int) -- ^ set of points + -> Maybe String -- ^ result, with unknown letters replaced with "?" +parseLetters = parseLetters' defaultLetterMap + +-- | A version of 'parseLettersEither'' accepting a custom 'LetterMap' +-- letterform database. +parseLettersEither' + :: LetterMap -- ^ database of letterforms + -> Set (Int, Int) + -> Maybe [Either (Set (Int, Int)) Char] +parseLettersEither' lm = (fmap . map . first . S.mapMonotonic) (\(V2 x y) -> (x, y)) + . parseLettersEitherV2 lm + . S.mapMonotonic (uncurry V2) + +-- | A version of 'parseLetters' returning a list of characters that were +-- either recognized or unrecognized; in the case of unrecognized +-- characters, returns the set of their coordinates but shifted to (0, 0) +-- as its upper left corner. +parseLettersEither + :: Set (Int, Int) + -> Maybe [Either (Set (Int, Int)) Char] +parseLettersEither = parseLettersEither' defaultLetterMap + +-- | A version of 'unsafeParseLetters'' accepting a custom 'LetterMap' +-- letterform database. +unsafeParseLetters' + :: LetterMap + -> Set (Int, Int) + -> String +unsafeParseLetters' lm = + fromMaybe (error "Advent.OCR.unsafeParseLetters': Unable to parse letters") + . parseLetters' lm + +-- | A version of 'parseLetters' that will be undefined ('error') when no +-- parse is found. +unsafeParseLetters + :: Set (Int, Int) + -> String +unsafeParseLetters = + fromMaybe (error "Advent.OCR.unsafeParseLetters: Unable to parse letters") + . parseLetters + +-- | Parse raw ASCII art into a set of points, usable with +-- 'parseLetters'. +parseAsciiMap + :: Set Char -- ^ characters to use as "on"/included + -> String -- ^ raw ASCII art + -> Set (Int, Int) +parseAsciiMap c = S.mapMonotonic (\(V2 x y) -> (x, y)) . parseAsciiMapV2 c + +-- | A version of 'asciiMapToLetters'' accepting a custom 'LetterMap' +-- letterform database. +asciiMapToLetters' + :: Set Char -- ^ characters to use as "on"/included in ASCII art + -> LetterMap -- ^ database of letterforms + -> String -- ^ raw ASCII art + -> Maybe String +asciiMapToLetters' c lm = parseLettersV2 lm . parseAsciiMapV2 c + +-- | Convenient all-in-one utility function combining 'parseAsciiMap' and +-- 'parseLetters', to directly parse ASCII art into its letters. +asciiMapToLetters + :: Set Char -- ^ characters to use as "on"/included in ASCII art + -> String -- ^ raw ASCII art + -> Maybe String +asciiMapToLetters c = asciiMapToLetters' c defaultLetterMap diff --git a/src/Advent/OCR/Internal.hs b/src/Advent/OCR/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Advent/OCR/Internal.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Advent.OCR.Internal +-- Copyright : (c) Justin Le 2020 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Internal utility functions for "Advent.OCR". + + +module Advent.OCR.Internal ( + -- * Parse + V2(..) + , Point + , parseLettersV2 + , parseLettersEitherV2 + , parseAsciiMapV2 + -- * Letter Map + , LetterMap(..) + , lookupLetterMap + , defaultLetterMap + , rawLetterforms1 + , rawLetterforms2 + , parseLetterMap + -- * Utility + , contiguousShapes + , contiguousShapesBy + ) where + +import Advent.OCR.LetterMap +import Data.Default.Class +import Data.Maybe +import Data.Monoid +import Data.Set (Set) +import Language.Haskell.TH.Lift +import qualified Data.Set as S + +-- | A version of 'Advent.OCR.parseLetters' taking 'Point'. Used +-- internally. +parseLettersV2 + :: LetterMap + -> Set Point + -> Maybe String +parseLettersV2 lm = (fmap . map) (either (const '?') id) + . parseLettersEitherV2 lm + +-- | A version of 'Advent.OCR.parseLettersEither' taking (and returning) +-- 'Point'. Used internally. +parseLettersEitherV2 + :: LetterMap + -> Set Point + -> Maybe [Either (Set Point) Char] +parseLettersEitherV2 lm letters = listToMaybe attempts + where + attempts = + [ res + | refl <- [id, reflX] + , rots <- [id, perp, negate, negate . perp] + , let ls = S.map (rots . refl) letters + ((Sum n, Sum goodCount), res) = tryMe ls + percGood = goodCount / n :: Double + , n > 0 && percGood >= 0.5 + ] + tryMe = traverse (\c -> maybe ((Sum 1, Sum 0), Left c) (((Sum 1, Sum 1),) . Right) . lookupLetterMap c $ lm) + . contiguousShapesBy v2x + perp (V2 x y) = V2 (negate y) x + reflX (V2 x y) = V2 (negate x) y + +-- | Default is compatible with all challenges in Advent of Code 2015 to +-- 2019. +instance Default LetterMap where + def = defaultLetterMap + +-- | The default lettermap compatible all challenges in Advent of Code 2015 +-- - 2019. +defaultLetterMap :: LetterMap +defaultLetterMap = $( lift $ uncurry parseLetterMap rawLetterforms1 + <> uncurry parseLetterMap rawLetterforms2 + ) diff --git a/src/Advent/OCR/LetterMap.hs b/src/Advent/OCR/LetterMap.hs new file mode 100644 --- /dev/null +++ b/src/Advent/OCR/LetterMap.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Advent.OCR.LetterMap ( + LetterMap(..) + , V2(..) + , Point + , contiguousShapes + , contiguousShapesBy + , parseAsciiMapV2 + , rawLetterforms1 + , rawLetterforms2 + , parseLetterMap + , lookupLetterMap + ) where + +import Data.Data (Data) +import Data.Foldable +import Data.Map (Map) +import Data.Monoid +import Data.Semigroup +import Data.Set (Set) +import GHC.Generics +import Instances.TH.Lift () +import Language.Haskell.TH.Lift +import Language.Haskell.TH.Syntax +import Text.Heredoc (here) +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Type used internally to represent points; useful for its 'Num' and +-- 'Applicative' instances. +data V2 a = V2 { v2x :: !a, v2y :: !a } + deriving (Show, Functor, Eq, Ord, Generic, Data) + +instance Applicative V2 where + pure x = V2 x x + V2 fx fy <*> V2 x y = V2 (fx x) (fy y) + +instance Num a => Num (V2 a) where + V2 x1 y1 + V2 x2 y2 = V2 (x1 + x2) (y1 + y2) + V2 x1 y1 - V2 x2 y2 = V2 (x1 - x2) (y1 - y2) + V2 x1 y1 * V2 x2 y2 = V2 (x1 * x2) (y1 * y2) + negate (V2 x y) = V2 (negate x) (negate y) + abs (V2 x y) = V2 (abs x) (abs y) + signum (V2 x y) = V2 (signum x) (signum y) + fromInteger x = V2 (fromInteger x) (fromInteger x) + +instance Fractional a => Fractional (V2 a) where + recip (V2 x y) = V2 (recip x) (recip y) + V2 x1 y1 / V2 x2 y2 = V2 (x1 / x2) (y1 / y2) + fromRational x = V2 (fromRational x) (fromRational x) + +instance Lift a => Lift (V2 a) where + lift (V2 x y) = do + lx <- lift x + ly <- lift y + pure $ AppE (AppE (ConE 'V2) lx) ly +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = fmap TExp . lift +#endif + +-- | A point is a 2-vector of ints. +type Point = V2 Int + +-- | The set of unconnected shapes, indexed by their original center of +-- mass +contiguousShapes :: Set Point -> Map (V2 Double) (Set (Set Point)) +contiguousShapes s0 = M.fromListWith (<>) + [ (com, S.singleton (S.map (subtract topCorner) s)) + | s <- allSubgraphs (S.fromList . fullNeighbs) s0 + , let com = mean (fmap fromIntegral) s + V2 topCorner _ = boundingBox s + ] + +allSubgraphs + :: forall a. Ord a + => (a -> Set a) -- ^ Expansion + -> Set a -- ^ points + -> [Set a] +allSubgraphs f = go [] + where + go !seen !rest = case S.minView rest of + Nothing -> seen + Just (x, xs) -> + let new = floodFill (S.intersection xs . f) (S.singleton x) + in go (new : seen) (xs `S.difference` new) + +-- | The set of unconnected shapes, sorted against some function on their +-- original center of masses. +contiguousShapesBy + :: Ord a + => (V2 Double -> a) + -> Set Point + -> [Set Point] +contiguousShapesBy f = concatMap toList . M.mapKeys f . contiguousShapes + +floodFill + :: Ord a + => (a -> Set a) -- ^ Expansion (be sure to limit allowed points) + -> Set a -- ^ Start points + -> Set a -- ^ Flood filled, with count of number of steps +floodFill f = go S.empty + where + go !innr !outr + | S.null outr' = innr' + | otherwise = go innr' outr' + where + innr' = S.union innr outr + outr' = foldMap f outr `S.difference` innr' + +fullNeighbs :: Point -> [Point] +fullNeighbs p = [ p + V2 dx dy + | dx <- [-1 .. 1] + , dy <- if dx == 0 then [-1,1] else [-1..1] + ] + +boundingBox :: (Bounded a, Foldable f, Applicative g, Ord a) => f (g a) -> V2 (g a) +boundingBox = (\(Ap mn, Ap mx) -> V2 (getMin <$> mn) (getMax <$> mx)) + . foldMap (\p -> (Ap (Min <$> p), Ap (Max <$> p))) + +-- | will error if empty list +mean :: (Foldable f, Fractional b) => (a -> b) -> f a -> b +mean f xs0 = sx1 / sx0 + where + (sx0, sx1) = go 0 0 (toList xs0) + go !x0 !x1 = \case + [] -> (x0, x1) + x:xs -> go (x0 + 1) (x1 + f x) xs + +-- | A database associating a set of "on" points to the +-- letter they represent. +-- +-- See 'Advent.OCR.Internal.defaultLetterMap' for a database compatible +-- with Advent of Code 2015-2019. +newtype LetterMap = LetterMap { getLetterMap :: Map (Set Point) Char } + deriving (Show, Eq, Ord, Semigroup, Monoid, Generic, Data) + +instance Lift LetterMap where + lift (LetterMap x) = AppE (ConE 'LetterMap) <$> lift x +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = fmap TExp . lift +#endif + +-- | Lookup a set of points for the letter it represents in a 'LetterMap'. +-- The set is expected to be aligned with (0,0) as the upper left corner of +-- its obunding box. +lookupLetterMap :: Set Point -> LetterMap -> Maybe Char +lookupLetterMap k = M.lookup k . getLetterMap + +-- | Given a list of characters and ASCII art for all those characters +-- (from left to right), builds the appropriate 'LetterMap'. +-- +-- An example usage would be: +-- +-- @ +-- 'parseLetterMap' "ABC" abcArt +-- @ +-- +-- where @abcArt@ is: +-- +-- > .##..###...##. +-- > #..#.#..#.#..# +-- > #..#.###..#... +-- > ####.#..#.#... +-- > #..#.#..#.#..# +-- > #..#.###...##. +-- +-- Expects ASCII art where @#@ is the "on"/included character. +parseLetterMap :: [Char] -> String -> LetterMap +parseLetterMap ls = LetterMap + . M.fromList + . zipWith (flip (,)) ls + . contiguousShapesBy v2x + . parseAsciiMapV2 (S.singleton '#') + +-- | Parse raw ASCII art into a set of points, usable with +-- 'Advent.OCR.Internal.parseLettersV2'. +parseAsciiMapV2 + :: Set Char -- ^ characters to use as "on"/included + -> String -- ^ raw map ASCII art + -> Set Point +parseAsciiMapV2 c = zipWithFold (\j -> zipWithFold (\i x -> + if x `S.member` c + then S.singleton (V2 i j) + else S.empty + ) [0..]) [0..] + . lines + +zipWithFold + :: Monoid m + => (a -> b -> m) + -> [a] + -> [b] + -> m +zipWithFold f xs = fold . zipWith f xs + +-- | Seen in 2016 Day 8, 2019 Day 8 and 11. 4x6 glyphs. +-- +-- Load using @uncurry 'parseLetterMap'@. +rawLetterforms1 :: (String, String) +rawLetterforms1 = ("ABCEFGHJKLPRUYZ", drop 1 [here| +.##..###...##..####.####..##..#..#...##.#..#.#....###..###..#..#.#...#.#### +#..#.#..#.#..#.#....#....#..#.#..#....#.#.#..#....#..#.#..#.#..#.#...#....# +#..#.###..#....###..###..#....####....#.##...#....#..#.#..#.#..#..#.#....#. +####.#..#.#....#....#....#.##.#..#....#.#.#..#....###..###..#..#...#....#.. +#..#.#..#.#..#.#....#....#..#.#..#.#..#.#.#..#....#....#.#..#..#...#...#... +#..#.###...##..####.#.....###.#..#..##..#..#.####.#....#..#..##....#...#### +|]) + +-- | Based on +-- . 6x10 +-- glyphs. +-- +-- Seen in 2018 Day 10. +-- +-- Load using @uncurry 'parseLetterMap'@. +rawLetterforms2 :: (String, String) +rawLetterforms2 = ("ABCEFGHJKLNPRXZ", drop 1 [here| +..##...#####...####..######.######..####..#....#....###.#....#.#......#....#.#####..#####..#....#.###### +.#..#..#....#.#....#.#......#......#....#.#....#.....#..#...#..#......##...#.#....#.#....#.#....#......# +#....#.#....#.#......#......#......#......#....#.....#..#..#...#......##...#.#....#.#....#..#..#.......# +#....#.#....#.#......#......#......#......#....#.....#..#.#....#......#.#..#.#....#.#....#..#..#......#. +#....#.#####..#......#####..#####..#......######.....#..##.....#......#.#..#.#####..#####....##......#.. +######.#....#.#......#......#......#..###.#....#.....#..##.....#......#..#.#.#......#..#.....##.....#... +#....#.#....#.#......#......#......#....#.#....#.....#..#.#....#......#..#.#.#......#...#...#..#...#.... +#....#.#....#.#......#......#......#....#.#....#.#...#..#..#...#......#...##.#......#...#...#..#..#..... +#....#.#....#.#....#.#......#......#...##.#....#.#...#..#...#..#......#...##.#......#....#.#....#.#..... +#....#.#####...####..######.#.......###.#.#....#..###...#....#.######.#....#.#......#....#.#....#.###### +|]) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE QuasiQuotes #-} + +import Advent.OCR +import Test.Hspec +import Text.Heredoc +import qualified Data.Set as S + +main :: IO () +main = hspec $ do + describe "2016 Day 8" $ do + it "should parse a sample result correctly" $ do + asciiMapToLetters (S.singleton '#') y2016d08 + `shouldBe` Just "ZJHRKCPLYJ" + describe "2018 Day 10" $ do + it "should parse a sample result correctly" $ do + asciiMapToLetters (S.singleton '#') y2018d10 + `shouldBe` Just "AHZLLCAL" + describe "2019 Day 8" $ do + it "should parse a sample result correctly" $ do + asciiMapToLetters (S.singleton '#') y2019d08 + `shouldBe` Just "UBUFP" + describe "2019 Day 11" $ do + it "should parse a sample result correctly, even mirrored" $ do + asciiMapToLetters (S.singleton '#') y2019d11 + `shouldBe` Just "JKZLZJBH" + +y2016d08 :: String +y2016d08 = drop 1 [here| +####...##.#..#.###..#..#..##..###..#....#...#..## +...#....#.#..#.#..#.#.#..#..#.#..#.#....#...#...# +..#.....#.####.#..#.##...#....#..#.#.....#.#....# +.#......#.#..#.###..#.#..#....###..#......#.....# +#....#..#.#..#.#.#..#.#..#..#.#....#......#..#..# +####..##..#..#.#..#.#..#..##..#....####...#...##. +|] + +y2018d10 :: String +y2018d10 = drop 1 [here| +..##....#....#..######..#.......#........####.....##....#..... +.#..#...#....#.......#..#.......#.......#....#...#..#...#..... +#....#..#....#.......#..#.......#.......#.......#....#..#..... +#....#..#....#......#...#.......#.......#.......#....#..#..... +#....#..######.....#....#.......#.......#.......#....#..#..... +######..#....#....#.....#.......#.......#.......######..#..... +#....#..#....#...#......#.......#.......#.......#....#..#..... +#....#..#....#..#.......#.......#.......#.......#....#..#..... +#....#..#....#..#.......#.......#.......#....#..#....#..#..... +#....#..#....#..######..######..######...####...#....#..###### +|] + +y2019d08 :: String +y2019d08 = drop 1 [here| +#..#.###..#..#.####.###. +#..#.#..#.#..#.#....#..# +#..#.###..#..#.###..#..# +#..#.#..#.#..#.#....###. +#..#.#..#.#..#.#....#... +.##..###...##..#....#... +|] + +y2019d11 :: String +y2019d11 = drop 1 [here| +.##..#..#.####.####.####..##..###..#..# +#..#.#.#..#....#....#....#..#.#..#.#..# +...#.#.#...#...#.....#......#.#..#.#..# +...#.##.....#..#......#.....#.###..#### +...#.#.#.....#.#.......#....#.#..#.#..# +..##.#..#.####.#....####...##.###..#..# +|]