{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{-|

Copyright:
  This file is part of the package zxcvbn-hs. It is subject to the
  license terms in the LICENSE file found in the top-level directory
  of this distribution and at:

    https://code.devalot.com/sthenauth/zxcvbn-hs

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: MIT

-}
module Text.Password.Strength.Internal.Adjacency (
  -- * Adjacency Matching (for Keyboard Patterns)
  Pattern,
  Direction(..),
  Move(..),
  Layer(..),
  Adjacency(..),
  AdjacencyTable(..),
  totalChars,
  averageNeighbors,
  patterns,
  findSequence,
  AdjacencyScore(..),
  patternLength,
  totalTurns,
  primaryLayer,
  secondaryLayer,
  scoreSequence
  ) where

--------------------------------------------------------------------------------
-- Library Imports:
import Control.Lens ((&), (^.), (+~), (.~))
import Control.Lens.TH (makeLenses)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Binary (Binary)
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)

--------------------------------------------------------------------------------
-- | A @Pattern@ is two Unicode characters next to one another in a password.
type Pattern = (Char, Char)

--------------------------------------------------------------------------------
-- | Direction of movement for adjacent characters.
data Direction = N | NE | E | SE | S | SW | W | NW
  deriving ((forall x. Direction -> Rep Direction x)
-> (forall x. Rep Direction x -> Direction) -> Generic Direction
forall x. Rep Direction x -> Direction
forall x. Direction -> Rep Direction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Direction x -> Direction
$cfrom :: forall x. Direction -> Rep Direction x
Generic, Get Direction
[Direction] -> Put
Direction -> Put
(Direction -> Put)
-> Get Direction -> ([Direction] -> Put) -> Binary Direction
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Direction] -> Put
$cputList :: [Direction] -> Put
get :: Get Direction
$cget :: Get Direction
put :: Direction -> Put
$cput :: Direction -> Put
Binary, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Eq Direction
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
$cp1Ord :: Eq Direction
Ord, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
(Direction -> Direction)
-> (Direction -> Direction)
-> (Int -> Direction)
-> (Direction -> Int)
-> (Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> Direction -> [Direction])
-> Enum Direction
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
$cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
enumFromTo :: Direction -> Direction -> [Direction]
$cenumFromTo :: Direction -> Direction -> [Direction]
enumFromThen :: Direction -> Direction -> [Direction]
$cenumFromThen :: Direction -> Direction -> [Direction]
enumFrom :: Direction -> [Direction]
$cenumFrom :: Direction -> [Direction]
fromEnum :: Direction -> Int
$cfromEnum :: Direction -> Int
toEnum :: Int -> Direction
$ctoEnum :: Int -> Direction
pred :: Direction -> Direction
$cpred :: Direction -> Direction
succ :: Direction -> Direction
$csucc :: Direction -> Direction
Enum, Direction
Direction -> Direction -> Bounded Direction
forall a. a -> a -> Bounded a
maxBound :: Direction
$cmaxBound :: Direction
minBound :: Direction
$cminBound :: Direction
Bounded)

--------------------------------------------------------------------------------
-- | Movement between characters.
data Move = Move Direction | Stay
  deriving ((forall x. Move -> Rep Move x)
-> (forall x. Rep Move x -> Move) -> Generic Move
forall x. Rep Move x -> Move
forall x. Move -> Rep Move x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Move x -> Move
$cfrom :: forall x. Move -> Rep Move x
Generic, Get Move
[Move] -> Put
Move -> Put
(Move -> Put) -> Get Move -> ([Move] -> Put) -> Binary Move
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Move] -> Put
$cputList :: [Move] -> Put
get :: Get Move
$cget :: Get Move
put :: Move -> Put
$cput :: Move -> Put
Binary, Int -> Move -> ShowS
[Move] -> ShowS
Move -> String
(Int -> Move -> ShowS)
-> (Move -> String) -> ([Move] -> ShowS) -> Show Move
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Move] -> ShowS
$cshowList :: [Move] -> ShowS
show :: Move -> String
$cshow :: Move -> String
showsPrec :: Int -> Move -> ShowS
$cshowsPrec :: Int -> Move -> ShowS
Show, Move -> Move -> Bool
(Move -> Move -> Bool) -> (Move -> Move -> Bool) -> Eq Move
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Move -> Move -> Bool
$c/= :: Move -> Move -> Bool
== :: Move -> Move -> Bool
$c== :: Move -> Move -> Bool
Eq)

--------------------------------------------------------------------------------
-- | Keyboard layers.
data Layer = Primary | Secondary
  deriving ((forall x. Layer -> Rep Layer x)
-> (forall x. Rep Layer x -> Layer) -> Generic Layer
forall x. Rep Layer x -> Layer
forall x. Layer -> Rep Layer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Layer x -> Layer
$cfrom :: forall x. Layer -> Rep Layer x
Generic, Get Layer
[Layer] -> Put
Layer -> Put
(Layer -> Put) -> Get Layer -> ([Layer] -> Put) -> Binary Layer
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Layer] -> Put
$cputList :: [Layer] -> Put
get :: Get Layer
$cget :: Get Layer
put :: Layer -> Put
$cput :: Layer -> Put
Binary, Int -> Layer -> ShowS
[Layer] -> ShowS
Layer -> String
(Int -> Layer -> ShowS)
-> (Layer -> String) -> ([Layer] -> ShowS) -> Show Layer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Layer] -> ShowS
$cshowList :: [Layer] -> ShowS
show :: Layer -> String
$cshow :: Layer -> String
showsPrec :: Int -> Layer -> ShowS
$cshowsPrec :: Int -> Layer -> ShowS
Show, Layer -> Layer -> Bool
(Layer -> Layer -> Bool) -> (Layer -> Layer -> Bool) -> Eq Layer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Layer -> Layer -> Bool
$c/= :: Layer -> Layer -> Bool
== :: Layer -> Layer -> Bool
$c== :: Layer -> Layer -> Bool
Eq, Eq Layer
Eq Layer
-> (Layer -> Layer -> Ordering)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Bool)
-> (Layer -> Layer -> Layer)
-> (Layer -> Layer -> Layer)
-> Ord Layer
Layer -> Layer -> Bool
Layer -> Layer -> Ordering
Layer -> Layer -> Layer
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Layer -> Layer -> Layer
$cmin :: Layer -> Layer -> Layer
max :: Layer -> Layer -> Layer
$cmax :: Layer -> Layer -> Layer
>= :: Layer -> Layer -> Bool
$c>= :: Layer -> Layer -> Bool
> :: Layer -> Layer -> Bool
$c> :: Layer -> Layer -> Bool
<= :: Layer -> Layer -> Bool
$c<= :: Layer -> Layer -> Bool
< :: Layer -> Layer -> Bool
$c< :: Layer -> Layer -> Bool
compare :: Layer -> Layer -> Ordering
$ccompare :: Layer -> Layer -> Ordering
$cp1Ord :: Eq Layer
Ord, Int -> Layer
Layer -> Int
Layer -> [Layer]
Layer -> Layer
Layer -> Layer -> [Layer]
Layer -> Layer -> Layer -> [Layer]
(Layer -> Layer)
-> (Layer -> Layer)
-> (Int -> Layer)
-> (Layer -> Int)
-> (Layer -> [Layer])
-> (Layer -> Layer -> [Layer])
-> (Layer -> Layer -> [Layer])
-> (Layer -> Layer -> Layer -> [Layer])
-> Enum Layer
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
$cenumFromThenTo :: Layer -> Layer -> Layer -> [Layer]
enumFromTo :: Layer -> Layer -> [Layer]
$cenumFromTo :: Layer -> Layer -> [Layer]
enumFromThen :: Layer -> Layer -> [Layer]
$cenumFromThen :: Layer -> Layer -> [Layer]
enumFrom :: Layer -> [Layer]
$cenumFrom :: Layer -> [Layer]
fromEnum :: Layer -> Int
$cfromEnum :: Layer -> Int
toEnum :: Int -> Layer
$ctoEnum :: Int -> Layer
pred :: Layer -> Layer
$cpred :: Layer -> Layer
succ :: Layer -> Layer
$csucc :: Layer -> Layer
Enum, Layer
Layer -> Layer -> Bounded Layer
forall a. a -> a -> Bounded a
maxBound :: Layer
$cmaxBound :: Layer
minBound :: Layer
$cminBound :: Layer
Bounded)

--------------------------------------------------------------------------------
-- | Information about how two characters are related to one another.
data Adjacency = Adjacency
  { Adjacency -> Move
_movement :: Move
    -- ^ The direction moving from the first to second character.

  , Adjacency -> Layer
_firstLayer :: Layer
    -- ^ The layer that the first character is on.

  , Adjacency -> Layer
_secondLayer :: Layer
    -- ^ The layer that the second character is on.
  }
  deriving ((forall x. Adjacency -> Rep Adjacency x)
-> (forall x. Rep Adjacency x -> Adjacency) -> Generic Adjacency
forall x. Rep Adjacency x -> Adjacency
forall x. Adjacency -> Rep Adjacency x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Adjacency x -> Adjacency
$cfrom :: forall x. Adjacency -> Rep Adjacency x
Generic, Get Adjacency
[Adjacency] -> Put
Adjacency -> Put
(Adjacency -> Put)
-> Get Adjacency -> ([Adjacency] -> Put) -> Binary Adjacency
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Adjacency] -> Put
$cputList :: [Adjacency] -> Put
get :: Get Adjacency
$cget :: Get Adjacency
put :: Adjacency -> Put
$cput :: Adjacency -> Put
Binary, Int -> Adjacency -> ShowS
[Adjacency] -> ShowS
Adjacency -> String
(Int -> Adjacency -> ShowS)
-> (Adjacency -> String)
-> ([Adjacency] -> ShowS)
-> Show Adjacency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Adjacency] -> ShowS
$cshowList :: [Adjacency] -> ShowS
show :: Adjacency -> String
$cshow :: Adjacency -> String
showsPrec :: Int -> Adjacency -> ShowS
$cshowsPrec :: Int -> Adjacency -> ShowS
Show)

makeLenses ''Adjacency

--------------------------------------------------------------------------------
-- | An adjacency graph (usually representing a single keyboard).
data AdjacencyTable = AdjacencyTable
  { AdjacencyTable -> Int
_totalChars :: Int
    -- ^ Total number of characters in the graph (total keys on the
    -- keyboard including all layers).

  , AdjacencyTable -> Int
_averageNeighbors :: Int
    -- ^ Average number of neighbors in the graph.

  , AdjacencyTable -> Map Pattern Adjacency
_patterns :: Map Pattern Adjacency
    -- ^ Dictionary for looking up patterns.

  } deriving ((forall x. AdjacencyTable -> Rep AdjacencyTable x)
-> (forall x. Rep AdjacencyTable x -> AdjacencyTable)
-> Generic AdjacencyTable
forall x. Rep AdjacencyTable x -> AdjacencyTable
forall x. AdjacencyTable -> Rep AdjacencyTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AdjacencyTable x -> AdjacencyTable
$cfrom :: forall x. AdjacencyTable -> Rep AdjacencyTable x
Generic, Get AdjacencyTable
[AdjacencyTable] -> Put
AdjacencyTable -> Put
(AdjacencyTable -> Put)
-> Get AdjacencyTable
-> ([AdjacencyTable] -> Put)
-> Binary AdjacencyTable
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AdjacencyTable] -> Put
$cputList :: [AdjacencyTable] -> Put
get :: Get AdjacencyTable
$cget :: Get AdjacencyTable
put :: AdjacencyTable -> Put
$cput :: AdjacencyTable -> Put
Binary, Int -> AdjacencyTable -> ShowS
[AdjacencyTable] -> ShowS
AdjacencyTable -> String
(Int -> AdjacencyTable -> ShowS)
-> (AdjacencyTable -> String)
-> ([AdjacencyTable] -> ShowS)
-> Show AdjacencyTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AdjacencyTable] -> ShowS
$cshowList :: [AdjacencyTable] -> ShowS
show :: AdjacencyTable -> String
$cshow :: AdjacencyTable -> String
showsPrec :: Int -> AdjacencyTable -> ShowS
$cshowsPrec :: Int -> AdjacencyTable -> ShowS
Show)

makeLenses ''AdjacencyTable

--------------------------------------------------------------------------------
-- | Find a pattern if it exists.  If all characters in the given
-- 'Text' form a pattern in the given 'Graph' then a list of matches
-- will be returned.
findSequence :: Text -> AdjacencyTable -> Maybe (NonEmpty Adjacency)
findSequence :: Text -> AdjacencyTable -> Maybe (NonEmpty Adjacency)
findSequence Text
t AdjacencyTable{Int
Map Pattern Adjacency
_patterns :: Map Pattern Adjacency
_averageNeighbors :: Int
_totalChars :: Int
_patterns :: AdjacencyTable -> Map Pattern Adjacency
_averageNeighbors :: AdjacencyTable -> Int
_totalChars :: AdjacencyTable -> Int
..} =
  let chars :: String
chars = Text -> String
Text.unpack Text
t
      ms :: Maybe [Adjacency]
ms = (Pattern -> Maybe Adjacency) -> [Pattern] -> Maybe [Adjacency]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern -> Map Pattern Adjacency -> Maybe Adjacency
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Pattern Adjacency
_patterns) (String -> String -> [Pattern]
forall a b. [a] -> [b] -> [(a, b)]
zip String
chars (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
chars))
  in [Adjacency] -> NonEmpty Adjacency
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([Adjacency] -> NonEmpty Adjacency)
-> Maybe [Adjacency] -> Maybe (NonEmpty Adjacency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Adjacency]
ms

--------------------------------------------------------------------------------
-- | Scoring information for adjacent characters.
data AdjacencyScore = AdjacencyScore
  { AdjacencyScore -> Int
_patternLength :: Int
    -- ^ Number of characters in the pattern.

  , AdjacencyScore -> Int
_totalTurns :: Int
    -- ^ Total number of turns needed.

  , AdjacencyScore -> Int
_primaryLayer :: Int
    -- ^ Characters that are on the primary layer.

  , AdjacencyScore -> Int
_secondaryLayer :: Int
    -- ^ Characters that are on a secondary layer.

  , AdjacencyScore -> Move
_lastMovement :: Move
    -- ^ The direction on the last character.

  } deriving (Int -> AdjacencyScore -> ShowS
[AdjacencyScore] -> ShowS
AdjacencyScore -> String
(Int -> AdjacencyScore -> ShowS)
-> (AdjacencyScore -> String)
-> ([AdjacencyScore] -> ShowS)
-> Show AdjacencyScore
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AdjacencyScore] -> ShowS
$cshowList :: [AdjacencyScore] -> ShowS
show :: AdjacencyScore -> String
$cshow :: AdjacencyScore -> String
showsPrec :: Int -> AdjacencyScore -> ShowS
$cshowsPrec :: Int -> AdjacencyScore -> ShowS
Show, AdjacencyScore -> AdjacencyScore -> Bool
(AdjacencyScore -> AdjacencyScore -> Bool)
-> (AdjacencyScore -> AdjacencyScore -> Bool) -> Eq AdjacencyScore
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AdjacencyScore -> AdjacencyScore -> Bool
$c/= :: AdjacencyScore -> AdjacencyScore -> Bool
== :: AdjacencyScore -> AdjacencyScore -> Bool
$c== :: AdjacencyScore -> AdjacencyScore -> Bool
Eq)

makeLenses ''AdjacencyScore

--------------------------------------------------------------------------------
instance Semigroup AdjacencyScore where
  <> :: AdjacencyScore -> AdjacencyScore -> AdjacencyScore
(<>) (AdjacencyScore Int
l Int
t Int
p Int
s Move
m) (AdjacencyScore Int
l' Int
t' Int
p' Int
s' Move
_) =
    Int -> Int -> Int -> Int -> Move -> AdjacencyScore
AdjacencyScore (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l') (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
t') (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
p') (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
s') Move
m

--------------------------------------------------------------------------------
instance Monoid AdjacencyScore where
  mempty :: AdjacencyScore
mempty = Int -> Int -> Int -> Int -> Move -> AdjacencyScore
AdjacencyScore Int
0 Int
0 Int
0 Int
0 Move
Stay

--------------------------------------------------------------------------------
-- | Calculate the score for two adjacent characters.
scoreSequence :: AdjacencyScore -> Adjacency -> AdjacencyScore
scoreSequence :: AdjacencyScore -> Adjacency -> AdjacencyScore
scoreSequence AdjacencyScore
s Adjacency
a =
  AdjacencyScore
s AdjacencyScore
-> (AdjacencyScore -> AdjacencyScore) -> AdjacencyScore
forall a b. a -> (a -> b) -> b
& AdjacencyScore -> AdjacencyScore
turns
    AdjacencyScore
-> (AdjacencyScore -> AdjacencyScore) -> AdjacencyScore
forall a b. a -> (a -> b) -> b
& AdjacencyScore -> AdjacencyScore
layers
    AdjacencyScore
-> (AdjacencyScore -> AdjacencyScore) -> AdjacencyScore
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> AdjacencyScore -> Identity AdjacencyScore
Lens' AdjacencyScore Int
patternLength ((Int -> Identity Int)
 -> AdjacencyScore -> Identity AdjacencyScore)
-> Int -> AdjacencyScore -> AdjacencyScore
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ (if (AdjacencyScore
s AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
patternLength) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
2 else Int
1)
    AdjacencyScore
-> (AdjacencyScore -> AdjacencyScore) -> AdjacencyScore
forall a b. a -> (a -> b) -> b
& (Move -> Identity Move)
-> AdjacencyScore -> Identity AdjacencyScore
Lens' AdjacencyScore Move
lastMovement  ((Move -> Identity Move)
 -> AdjacencyScore -> Identity AdjacencyScore)
-> Move -> AdjacencyScore -> AdjacencyScore
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Adjacency
a Adjacency -> Getting Move Adjacency Move -> Move
forall s a. s -> Getting a s a -> a
^. Getting Move Adjacency Move
Lens' Adjacency Move
movement)

  where
    turns :: AdjacencyScore -> AdjacencyScore
    turns :: AdjacencyScore -> AdjacencyScore
turns = if (Adjacency
a Adjacency -> Getting Move Adjacency Move -> Move
forall s a. s -> Getting a s a -> a
^. Getting Move Adjacency Move
Lens' Adjacency Move
movement) Move -> Move -> Bool
forall a. Eq a => a -> a -> Bool
/= (AdjacencyScore
s AdjacencyScore -> Getting Move AdjacencyScore Move -> Move
forall s a. s -> Getting a s a -> a
^. Getting Move AdjacencyScore Move
Lens' AdjacencyScore Move
lastMovement)
              then (Int -> Identity Int) -> AdjacencyScore -> Identity AdjacencyScore
Lens' AdjacencyScore Int
totalTurns ((Int -> Identity Int)
 -> AdjacencyScore -> Identity AdjacencyScore)
-> Int -> AdjacencyScore -> AdjacencyScore
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1
              else AdjacencyScore -> AdjacencyScore
forall a. a -> a
id

    -- Usually we focus on the layer of the second character but when
    -- we are looking at the start of the pattern we need to consider
    -- both characters.
    layers :: AdjacencyScore -> AdjacencyScore
    layers :: AdjacencyScore -> AdjacencyScore
layers = if (AdjacencyScore
s AdjacencyScore -> Getting Int AdjacencyScore Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int AdjacencyScore Int
Lens' AdjacencyScore Int
patternLength) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
               then Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a Adjacency -> Getting Layer Adjacency Layer -> Layer
forall s a. s -> Getting a s a -> a
^. Getting Layer Adjacency Layer
Lens' Adjacency Layer
firstLayer) (AdjacencyScore -> AdjacencyScore)
-> (AdjacencyScore -> AdjacencyScore)
-> AdjacencyScore
-> AdjacencyScore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AdjacencyScore
-> (AdjacencyScore -> AdjacencyScore) -> AdjacencyScore
forall a b. a -> (a -> b) -> b
& Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a Adjacency -> Getting Layer Adjacency Layer -> Layer
forall s a. s -> Getting a s a -> a
^. Getting Layer Adjacency Layer
Lens' Adjacency Layer
secondLayer))
               else Layer -> AdjacencyScore -> AdjacencyScore
layer (Adjacency
a Adjacency -> Getting Layer Adjacency Layer -> Layer
forall s a. s -> Getting a s a -> a
^. Getting Layer Adjacency Layer
Lens' Adjacency Layer
secondLayer)

    layer :: Layer -> AdjacencyScore -> AdjacencyScore
    layer :: Layer -> AdjacencyScore -> AdjacencyScore
layer Layer
Primary   = (Int -> Identity Int) -> AdjacencyScore -> Identity AdjacencyScore
Lens' AdjacencyScore Int
primaryLayer   ((Int -> Identity Int)
 -> AdjacencyScore -> Identity AdjacencyScore)
-> Int -> AdjacencyScore -> AdjacencyScore
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1
    layer Layer
Secondary = (Int -> Identity Int) -> AdjacencyScore -> Identity AdjacencyScore
Lens' AdjacencyScore Int
secondaryLayer ((Int -> Identity Int)
 -> AdjacencyScore -> Identity AdjacencyScore)
-> Int -> AdjacencyScore -> AdjacencyScore
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1