{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Codec.QRCode.Code.Mask
  ( applyMask
  , getPenaltyScore
  ) where

import           Codec.QRCode.Base

import           Control.Monad.Primitive     (PrimMonad, PrimState)
import qualified Data.Vector.Unboxed         as UV
import qualified Data.Vector.Unboxed.Mutable as MUV

import           Codec.QRCode.Code.Image
import           Codec.QRCode.Data.Mask
import           Codec.QRCode.Data.MQRImage
import           Codec.QRCode.Data.QRImage

-- | Apply the mask to the image, modules marked for functions are excluded.
applyMask :: forall m. PrimMonad m => MQRImage3 (PrimState m) -> Mask -> m ()
applyMask :: MQRImage3 (PrimState m) -> Mask -> m ()
applyMask img :: MQRImage3 (PrimState m)
img@MQRImage3{Int
MVector (PrimState m) Bool
Vector Bool
ErrorLevel
Version
mqrImage3ErrorLevel :: forall s. MQRImage3 s -> ErrorLevel
mqrImage3Version :: forall s. MQRImage3 s -> Version
mqrImage3Fixed :: forall s. MQRImage3 s -> Vector Bool
mqrImage3Data :: forall s. MQRImage3 s -> MVector s Bool
mqrImage3Size :: forall s. MQRImage3 s -> Int
mqrImage3ErrorLevel :: ErrorLevel
mqrImage3Version :: Version
mqrImage3Fixed :: Vector Bool
mqrImage3Data :: MVector (PrimState m) Bool
mqrImage3Size :: Int
..} Mask
m = do
  -- draw format information
  MQRImage3 (PrimState m) -> Mask -> m ()
forall (m :: * -> *).
PrimMonad m =>
MQRImage3 (PrimState m) -> Mask -> m ()
drawFormatBits MQRImage3 (PrimState m)
img Mask
m
  -- select correct mask
  case Mask
m of
    Mask
Mask0 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask1 -> (Int -> Int -> Bool) -> m ()
go (\Int
_ Int
y -> Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask2 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
_ -> Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask3 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask4 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask5 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask6 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask7 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
  where
    go :: (Int -> Int -> Bool) -> m ()
    go :: (Int -> Int -> Bool) -> m ()
go Int -> Int -> Bool
m' =
      -- iterate over all modules
      [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (Int
mqrImage3Size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mqrImage3Size) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
pos -> do
        let
          (Int
y, Int
x) = Int
pos Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
mqrImage3Size
        -- when it's not a function module and the mask tells to invert, do it
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Vector Bool
mqrImage3Fixed Vector Bool -> Int -> Bool
forall a. Unbox a => Vector a -> Int -> a
UV.! Int
pos) Bool -> Bool -> Bool
&& Int -> Int -> Bool
m' Int
x Int
y) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          MVector (PrimState m) Bool -> (Bool -> Bool) -> Int -> m ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MUV.modify MVector (PrimState m) Bool
mqrImage3Data Bool -> Bool
not Int
pos

-- | Calculate the penalty score for an image
getPenaltyScore :: QRImage -> Int
getPenaltyScore :: QRImage -> Int
getPenaltyScore QRImage{Int
Vector Bool
ErrorLevel
qrImageData :: QRImage -> Vector Bool
qrImageSize :: QRImage -> Int
qrErrorLevel :: QRImage -> ErrorLevel
qrVersion :: QRImage -> Int
qrImageData :: Vector Bool
qrImageSize :: Int
qrErrorLevel :: ErrorLevel
qrVersion :: Int
..} = (forall s. ST s Int) -> Int
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Int) -> Int) -> (forall s. ST s Int) -> Int
forall a b. (a -> b) -> a -> b
$ do
  STRef s Int
result <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
y -> do
    -- Adjacent modules in row having same color
    (Bool, Int)
-> [Int] -> ((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ()
forall (f :: * -> *) (t :: * -> *) a a.
(Foldable t, Monad f) =>
a -> t a -> (a -> a -> f a) -> f ()
ffoldlM_ (Bool
False, Int
0 :: Int) [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] (((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ())
-> ((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Bool
pp, Int
run) Int
x ->
      case Int -> Int -> Bool
p Int
x Int
y of
        Bool
np
          | Bool
pp Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
np ->
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
np, Int
1)
          | Int
run Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 ->
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          | Int
run Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> do
              STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
penaltyN1)
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          | Bool
otherwise -> do
              STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    -- Adjacent modules in column having same color
    (Bool, Int)
-> [Int] -> ((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ()
forall (f :: * -> *) (t :: * -> *) a a.
(Foldable t, Monad f) =>
a -> t a -> (a -> a -> f a) -> f ()
ffoldlM_ (Bool
False, Int
0 :: Int) [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] (((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ())
-> ((Bool, Int) -> Int -> ST s (Bool, Int)) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Bool
pp, Int
run) Int
x ->
      case Int -> Int -> Bool
p Int
y Int
x of
        Bool
np
          | Bool
pp Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
np ->
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
np, Int
1)
          | Int
run Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 ->
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          | Int
run Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> do
              STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
penaltyN1)
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          | Bool
otherwise -> do
              STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              (Bool, Int) -> ST s (Bool, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

  -- 2*2 blocks of modules having same color
  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
y ->
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
x -> do
      let
        pxy :: Bool
pxy = Int -> Int -> Bool
p Int
x Int
y
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pxy Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int -> Bool
p (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
y Bool -> Bool -> Bool
&& Bool
pxy Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int -> Bool
p Int
x (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Bool -> Bool -> Bool
&& Bool
pxy Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int -> Bool
p (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
        STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
penaltyN2)

  [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
y -> do
    -- Finder-like pattern in rows
    Int -> [Int] -> (Int -> Int -> ST s Int) -> ST s ()
forall (f :: * -> *) (t :: * -> *) a a.
(Foldable t, Monad f) =>
a -> t a -> (a -> a -> f a) -> f ()
ffoldlM_ (Int
0 :: Int) [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> Int -> ST s Int) -> ST s ())
-> (Int -> Int -> ST s Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
bits' Int
x -> do
      let
        bits :: Int
bits = ((Int
bits' Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7ff) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
1 (Int -> Int -> Bool
p Int
x Int
y)
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
&& (Int
bits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0b00001011101 Bool -> Bool -> Bool
|| Int
bits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0b10111010000)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
        STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
penaltyN3)
      Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bits
    -- Finder-like pattern in columns
    Int -> [Int] -> (Int -> Int -> ST s Int) -> ST s ()
forall (f :: * -> *) (t :: * -> *) a a.
(Foldable t, Monad f) =>
a -> t a -> (a -> a -> f a) -> f ()
ffoldlM_ (Int
0 :: Int) [Int
0 .. Int
qrImageSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> Int -> ST s Int) -> ST s ())
-> (Int -> Int -> ST s Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
bits' Int
x -> do
      let
        bits :: Int
bits = ((Int
bits' Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7ff) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
1 (Int -> Int -> Bool
p Int
y Int
x)
      Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
&& (Int
bits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0b00001011101 Bool -> Bool -> Bool
|| Int
bits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0b10111010000)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
        STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
penaltyN3)
      Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bits

  -- Balance of black and white modules
  let
    black :: Int
black = (Int -> Bool -> Int) -> Int -> Vector Bool -> Int
forall b a. Unbox b => (a -> b -> a) -> a -> Vector b -> a
UV.foldl' (\Int
c Bool
pxy -> Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
0 Int
1 Bool
pxy) Int
0 Vector Bool
qrImageData
    halfOfTotalMulTwo :: Int
halfOfTotalMulTwo = Int
qrImageSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
qrImageSize
    differenceToMiddleMulTwo :: Int
differenceToMiddleMulTwo = Int -> Int
forall a. Num a => a -> a
abs (Int
blackInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
halfOfTotalMulTwo)
    steps :: Int
steps = (Int
differenceToMiddleMulTwo Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
halfOfTotalMulTwo
  STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
penaltyN4))

  STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
result
  where
    {-# INLINE ffoldlM_ #-}
    ffoldlM_ :: a -> t a -> (a -> a -> f a) -> f ()
ffoldlM_ a
a t a
b a -> a -> f a
c = f a -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f a -> f ()) -> f a -> f ()
forall a b. (a -> b) -> a -> b
$ (a -> a -> f a) -> a -> t a -> f a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM a -> a -> f a
c a
a t a
b
    {-# INLINE p #-}
    p :: Int -> Int -> Bool
p Int
x Int
y = Vector Bool
qrImageData Vector Bool -> Int -> Bool
forall a. Unbox a => Vector a -> Int -> a
UV.! (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
qrImageSize)
    penaltyN1 :: Int
penaltyN1 = Int
3
    penaltyN2 :: Int
penaltyN2 = Int
3
    penaltyN3 :: Int
penaltyN3 = Int
40
    penaltyN4 :: Int
penaltyN4 = Int
10