{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Advent.OCR.Internal (
V2(..)
, Point
, parseLettersV2
, parseLettersEitherV2
, parseAsciiMapV2
, LetterMap(..)
, lookupLetterMap
, defaultLetterMap
, rawLetterforms1
, rawLetterforms2
, parseLetterMap
, 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
parseLettersV2
:: LetterMap
-> Set Point
-> Maybe String
parseLettersV2 :: LetterMap -> Set Point -> Maybe String
parseLettersV2 LetterMap
lm = (([Either (Set Point) Char] -> String)
-> Maybe [Either (Set Point) Char] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Either (Set Point) Char] -> String)
-> Maybe [Either (Set Point) Char] -> Maybe String)
-> ((Either (Set Point) Char -> Char)
-> [Either (Set Point) Char] -> String)
-> (Either (Set Point) Char -> Char)
-> Maybe [Either (Set Point) Char]
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (Set Point) Char -> Char)
-> [Either (Set Point) Char] -> String
forall a b. (a -> b) -> [a] -> [b]
map) ((Set Point -> Char)
-> (Char -> Char) -> Either (Set Point) Char -> Char
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Char -> Set Point -> Char
forall a b. a -> b -> a
const Char
'?') Char -> Char
forall a. a -> a
id)
(Maybe [Either (Set Point) Char] -> Maybe String)
-> (Set Point -> Maybe [Either (Set Point) Char])
-> Set Point
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetterMap -> Set Point -> Maybe [Either (Set Point) Char]
parseLettersEitherV2 LetterMap
lm
parseLettersEitherV2
:: LetterMap
-> Set Point
-> Maybe [Either (Set Point) Char]
parseLettersEitherV2 :: LetterMap -> Set Point -> Maybe [Either (Set Point) Char]
parseLettersEitherV2 LetterMap
lm Set Point
letters = [[Either (Set Point) Char]] -> Maybe [Either (Set Point) Char]
forall a. [a] -> Maybe a
listToMaybe [[Either (Set Point) Char]]
attempts
where
attempts :: [[Either (Set Point) Char]]
attempts =
[ [Either (Set Point) Char]
res
| Point -> Point
refl <- [Point -> Point
forall a. a -> a
id, Point -> Point
forall a. Num a => V2 a -> V2 a
reflX]
, Point -> Point
rots <- [Point -> Point
forall a. a -> a
id, Point -> Point
forall a. Num a => V2 a -> V2 a
perp, Point -> Point
forall a. Num a => a -> a
negate, Point -> Point
forall a. Num a => a -> a
negate (Point -> Point) -> (Point -> Point) -> Point -> Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
forall a. Num a => V2 a -> V2 a
perp]
, let ls :: Set Point
ls = (Point -> Point) -> Set Point -> Set Point
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Point -> Point
rots (Point -> Point) -> (Point -> Point) -> Point -> Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
refl) Set Point
letters
((Sum Double
n, Sum Double
goodCount), [Either (Set Point) Char]
res) = Set Point -> ((Sum Double, Sum Double), [Either (Set Point) Char])
tryMe Set Point
ls
percGood :: Double
percGood = Double
goodCount Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n :: Double
, Double
n Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
percGood Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.5
]
tryMe :: Set Point -> ((Sum Double, Sum Double), [Either (Set Point) Char])
tryMe = (Set Point -> ((Sum Double, Sum Double), Either (Set Point) Char))
-> [Set Point]
-> ((Sum Double, Sum Double), [Either (Set Point) Char])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Set Point
c -> ((Sum Double, Sum Double), Either (Set Point) Char)
-> (Char -> ((Sum Double, Sum Double), Either (Set Point) Char))
-> Maybe Char
-> ((Sum Double, Sum Double), Either (Set Point) Char)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Double -> Sum Double
forall a. a -> Sum a
Sum Double
1, Double -> Sum Double
forall a. a -> Sum a
Sum Double
0), Set Point -> Either (Set Point) Char
forall a b. a -> Either a b
Left Set Point
c) (((Double -> Sum Double
forall a. a -> Sum a
Sum Double
1, Double -> Sum Double
forall a. a -> Sum a
Sum Double
1),) (Either (Set Point) Char
-> ((Sum Double, Sum Double), Either (Set Point) Char))
-> (Char -> Either (Set Point) Char)
-> Char
-> ((Sum Double, Sum Double), Either (Set Point) Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Either (Set Point) Char
forall a b. b -> Either a b
Right) (Maybe Char -> ((Sum Double, Sum Double), Either (Set Point) Char))
-> (LetterMap -> Maybe Char)
-> LetterMap
-> ((Sum Double, Sum Double), Either (Set Point) Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Point -> LetterMap -> Maybe Char
lookupLetterMap Set Point
c (LetterMap -> ((Sum Double, Sum Double), Either (Set Point) Char))
-> LetterMap -> ((Sum Double, Sum Double), Either (Set Point) Char)
forall a b. (a -> b) -> a -> b
$ LetterMap
lm)
([Set Point]
-> ((Sum Double, Sum Double), [Either (Set Point) Char]))
-> (Set Point -> [Set Point])
-> Set Point
-> ((Sum Double, Sum Double), [Either (Set Point) Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Double -> Double) -> Set Point -> [Set Point]
forall a. Ord a => (V2 Double -> a) -> Set Point -> [Set Point]
contiguousShapesBy V2 Double -> Double
forall a. V2 a -> a
v2x
perp :: V2 a -> V2 a
perp (V2 a
x a
y) = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (a -> a
forall a. Num a => a -> a
negate a
y) a
x
reflX :: V2 a -> V2 a
reflX (V2 a
x a
y) = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (a -> a
forall a. Num a => a -> a
negate a
x) a
y
instance Default LetterMap where
def :: LetterMap
def = LetterMap
defaultLetterMap
defaultLetterMap :: LetterMap
defaultLetterMap :: LetterMap
defaultLetterMap = $( lift $ uncurry parseLetterMap rawLetterforms1
<> uncurry parseLetterMap rawLetterforms2
)