{-# 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 :: forall (m :: * -> *).
PrimMonad m =>
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
  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 forall a. Num a => a -> a -> a
+ Int
y) forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask1 -> (Int -> Int -> Bool) -> m ()
go (\Int
_ Int
y -> Int
y forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask2 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
_ -> Int
x forall a. Integral a => a -> a -> a
`mod` Int
3 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask3 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x forall a. Num a => a -> a -> a
+ Int
y) forall a. Integral a => a -> a -> a
`mod` Int
3 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask4 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x forall a. Integral a => a -> a -> a
`div` Int
3 forall a. Num a => a -> a -> a
+ Int
y forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask5 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> Int
x forall a. Num a => a -> a -> a
* Int
y forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Num a => a -> a -> a
+ Int
x forall a. Num a => a -> a -> a
* Int
y forall a. Integral a => a -> a -> a
`mod` Int
3 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask6 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> (Int
x forall a. Num a => a -> a -> a
* Int
y forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Num a => a -> a -> a
+ Int
x forall a. Num a => a -> a -> a
* Int
y forall a. Integral a => a -> a -> a
`mod` Int
3) forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Eq a => a -> a -> Bool
== Int
0)
    Mask
Mask7 -> (Int -> Int -> Bool) -> m ()
go (\Int
x Int
y -> ((Int
x forall a. Num a => a -> a -> a
+ Int
y) forall a. Integral a => a -> a -> a
`mod` Int
2 forall a. Num a => a -> a -> a
+ Int
x forall a. Num a => a -> a -> a
* Int
y forall a. Integral a => a -> a -> a
`mod` Int
3) forall a. Integral a => a -> a -> a
`mod` Int
2 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
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (Int
mqrImage3Size forall a. Num a => a -> a -> a
* Int
mqrImage3Size) forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
pos -> do
        let
          (Int
y, Int
x) = Int
pos 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Vector Bool
mqrImage3Fixed forall a. Unbox a => Vector a -> Int -> a
UV.! Int
pos) Bool -> Bool -> Bool
&& Int -> Int -> Bool
m' Int
x Int
y) forall a b. (a -> b) -> a -> b
$
          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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  STRef s Int
result <- forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
qrImageSizeforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
y -> do
    -- Adjacent modules in row having same color
    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
qrImageSizeforall a. Num a => a -> a -> a
-Int
1] 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 forall a. Eq a => a -> a -> Bool
/= Bool
np ->
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
np, Int
1)
          | Int
run forall a. Ord a => a -> a -> Bool
< Int
5 ->
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)
          | Int
run forall a. Eq a => a -> a -> Bool
== Int
5 -> do
              forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (forall a. Num a => a -> a -> a
+Int
penaltyN1)
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)
          | Bool
otherwise -> do
              forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (forall a. Num a => a -> a -> a
+Int
1)
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)
    -- Adjacent modules in column having same color
    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
qrImageSizeforall a. Num a => a -> a -> a
-Int
1] 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 forall a. Eq a => a -> a -> Bool
/= Bool
np ->
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
np, Int
1)
          | Int
run forall a. Ord a => a -> a -> Bool
< Int
5 ->
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)
          | Int
run forall a. Eq a => a -> a -> Bool
== Int
5 -> do
              forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (forall a. Num a => a -> a -> a
+Int
penaltyN1)
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)
          | Bool
otherwise -> do
              forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
result (forall a. Num a => a -> a -> a
+Int
1)
              forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
pp, Int
runforall a. Num a => a -> a -> a
+Int
1)

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

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

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

  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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall a. Unbox a => Vector a -> Int -> a
UV.! (Int
x forall a. Num a => a -> a -> a
+ Int
y 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