module Cooked.Tweak.OutPermutations
( PermutOutTweakMode (..),
allOutPermutsTweak,
singleOutPermutTweak,
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)
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
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
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'
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
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'