-- | This module provides tweaks to modify the order of outputs in a transaction
-- skeleton. This can be useful since some validators expect a certain rigid
-- output order to make sense of them.
module Cooked.Tweak.OutPermutations
  ( PermutOutTweakMode (..),
    allOutPermutsTweak,
    singleOutPermutTweak,

    -- * For testing purposes
    distinctPermutations,
  )
where

import Control.Monad
import Cooked.Skeleton
import Cooked.Tweak.Common
import System.Random
import System.Random.Shuffle

data PermutOutTweakMode = KeepIdentity (Maybe Int) | OmitIdentity (Maybe Int)

-- | Modify transactions by changing the ordering of output constraints. If the
-- 'PermutTweakMode' is
--
-- - @KeepIdentity (Just n)@, the unmodified transaction is included in the list
--   of modified transactions and only the first n outputs are permuted,
--
-- - @KeepIdentity Nothing@, the unmodified transaction is included and all
--   outputs are permuted. Use this with care; there might be a lot of
--   permutations!
--
-- - @OmitIdentity (Just n)@, the unmodified transaction is not included in the
--   list of modified transactions and only the first n outputs are permuted,
--
-- - @OmitIdentity Nothing@, the unmodified transaction is not included and all
--   outputs are permuted. Use this with care; there might be a lot of
--   permutations!
--
-- (In particular, this is clever enough to generate only the distinct
-- permutations, even if some outputs are identical.)
allOutPermutsTweak :: (MonadTweak m) => PermutOutTweakMode -> m ()
allOutPermutsTweak :: forall (m :: * -> *). MonadTweak m => PermutOutTweakMode -> m ()
allOutPermutsTweak PermutOutTweakMode
mode = do
  [TxSkelOut]
oldOut <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> m [TxSkelOut]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL
  [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m ()] -> m ()) -> [m ()] -> m ()
forall a b. (a -> b) -> a -> b
$
    ([TxSkelOut] -> m ()) -> [[TxSkelOut]] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map
      (Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL)
      ([TxSkelOut] -> [[TxSkelOut]]
perms [TxSkelOut]
oldOut)
  where
    perms :: [TxSkelOut] -> [[TxSkelOut]]
perms = case PermutOutTweakMode
mode of
      KeepIdentity (Just Int
n) -> \[TxSkelOut]
l -> ([TxSkelOut] -> [TxSkelOut]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> [a] -> [b]
map ([TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ Int -> [TxSkelOut] -> [TxSkelOut]
forall a. Int -> [a] -> [a]
drop Int
n [TxSkelOut]
l) ([[TxSkelOut]] -> [[TxSkelOut]]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> [[TxSkelOut]]
forall a. Eq a => [a] -> [[a]]
distinctPermutations (Int -> [TxSkelOut] -> [TxSkelOut]
forall a. Int -> [a] -> [a]
take Int
n [TxSkelOut]
l)
      KeepIdentity Maybe Int
Nothing -> [TxSkelOut] -> [[TxSkelOut]]
forall a. Eq a => [a] -> [[a]]
distinctPermutations
      OmitIdentity (Just Int
n) -> \[TxSkelOut]
l -> ([TxSkelOut] -> [TxSkelOut]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> [a] -> [b]
map ([TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ Int -> [TxSkelOut] -> [TxSkelOut]
forall a. Int -> [a] -> [a]
drop Int
n [TxSkelOut]
l) ([[TxSkelOut]] -> [[TxSkelOut]]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> [[TxSkelOut]]
forall a. Eq a => [a] -> [[a]]
nonIdentityPermutations (Int -> [TxSkelOut] -> [TxSkelOut]
forall a. Int -> [a] -> [a]
take Int
n [TxSkelOut]
l)
      OmitIdentity Maybe Int
Nothing -> [TxSkelOut] -> [[TxSkelOut]]
forall a. Eq a => [a] -> [[a]]
nonIdentityPermutations

-- This is implemented so that duplicate entries in the input list don't give
-- rise to duplicate permutations.
distinctPermutations :: (Eq a) => [a] -> [[a]]
distinctPermutations :: forall a. Eq a => [a] -> [[a]]
distinctPermutations = ([a] -> [[a]] -> [[a]]) -> [[a]] -> [[a]] -> [[a]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([a] -> [[a]]) -> [[a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([a] -> [[a]]) -> [[a]] -> [[a]])
-> ([a] -> [a] -> [[a]]) -> [a] -> [[a]] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
insertSomewhere) [[]] ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
groupEq
  where
    -- group all equal elements. If we had @Ord a@, we could implement this more
    -- effifiently as @group . sort@.
    groupEq :: (Eq a) => [a] -> [[a]]
    groupEq :: forall a. Eq a => [a] -> [[a]]
groupEq [a]
l = (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (a -> [a] -> Int
forall a. Eq a => a -> [a] -> Int
count a
x [a]
l) a
x) ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Eq a => [a] -> [a]
makeUnique [a]
l
      where
        count :: (Eq a) => a -> [a] -> Int
        count :: forall a. Eq a => a -> [a] -> Int
count a
_ [] = Int
0
        count a
a (a
b : [a]
bs) = if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b then a -> [a] -> Int
forall a. Eq a => a -> [a] -> Int
count a
a [a]
bs else Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> [a] -> Int
forall a. Eq a => a -> [a] -> Int
count a
a [a]
bs

        makeUnique :: (Eq a) => [a] -> [a]
        makeUnique :: forall a. Eq a => [a] -> [a]
makeUnique [] = []
        makeUnique (a
x : [a]
xs) =
          let xs' :: [a]
xs' = [a] -> [a]
forall a. Eq a => [a] -> [a]
makeUnique [a]
xs
           in if a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs' then [a]
xs' else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs'

    -- all possibilities to insert elements from the left list into the right
    -- list
    insertSomewhere :: [a] -> [a] -> [[a]]
    insertSomewhere :: forall a. [a] -> [a] -> [[a]]
insertSomewhere [] [a]
ys = [[a]
ys]
    insertSomewhere [a]
xs [] = [[a]
xs]
    insertSomewhere l :: [a]
l@(a
x : [a]
xs) r :: [a]
r@(a
y : [a]
ys) =
      ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
insertSomewhere [a]
xs [a]
r) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
insertSomewhere [a]
l [a]
ys)

nonIdentityPermutations :: (Eq a) => [a] -> [[a]]
nonIdentityPermutations :: forall a. Eq a => [a] -> [[a]]
nonIdentityPermutations [a]
l = [a] -> [[a]] -> [[a]]
forall a. Eq a => a -> [a] -> [a]
removeFirst [a]
l ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
distinctPermutations [a]
l
  where
    removeFirst :: (Eq a) => a -> [a] -> [a]
    removeFirst :: forall a. Eq a => a -> [a] -> [a]
removeFirst a
_ [] = []
    removeFirst a
x (a
y : [a]
ys) = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then [a]
ys else a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
removeFirst a
x [a]
ys

-- | This randomly permutes the outputs of a transaction with a given seed Can
-- be used to assess if a certain validator is order-dependant
singleOutPermutTweak :: (MonadTweak m) => Int -> m ()
singleOutPermutTweak :: forall (m :: * -> *). MonadTweak m => Int -> m ()
singleOutPermutTweak Int
seed = do
  [TxSkelOut]
outputs <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> m [TxSkelOut]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL
  let outputs' :: [TxSkelOut]
outputs' = [TxSkelOut] -> Int -> StdGen -> [TxSkelOut]
forall gen a. RandomGen gen => [a] -> Int -> gen -> [a]
shuffle' [TxSkelOut]
outputs ([TxSkelOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxSkelOut]
outputs) (Int -> StdGen
mkStdGen Int
seed)
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ [TxSkelOut]
outputs' [TxSkelOut] -> [TxSkelOut] -> Bool
forall a. Eq a => a -> a -> Bool
/= [TxSkelOut]
outputs
  Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL [TxSkelOut]
outputs'