{-|
Module      : MachineLearning.TIR.Mutation
Description : TIR expression data structures
Copyright   : (c) Fabricio Olivetti de Franca, 2022
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

Mutation operators.
-}
module MachineLearning.TIR.Mutation where

import MachineLearning.TIR
import MachineLearning.Utils.Config
import Control.Evolution
import Control.Monad.State.Strict
import System.Random
import Data.List (sortOn, groupBy, (\\))

toss :: Rnd Bool 
toss :: Rnd Bool
toss = (StdGen -> (Bool, StdGen)) -> Rnd Bool
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state StdGen -> (Bool, StdGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
{-# INLINE toss #-}

randomChoice :: Rnd a -> Rnd a -> Rnd a
randomChoice :: forall a. Rnd a -> Rnd a -> Rnd a
randomChoice Rnd a
f Rnd a
g = do
  Bool
coin <- Rnd Bool
toss
  if Bool
coin
     then Rnd a
f
     else Rnd a
g
{-# INLINE randomChoice #-}

trd :: Pi -> [(Int, Int)]
trd :: Pi -> [(Int, Int)]
trd (Double
_,Function
_,[(Int, Int)]
x) = [(Int, Int)]
x
{-# INLINE trd #-}

countVars :: Sigma -> Int
countVars :: Sigma -> Int
countVars = (Pi -> Int -> Int) -> Int -> Sigma -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Double
_,Function
_,[(Int, Int)]
x) Int
acc -> [(Int, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
acc) Int
0
{-# INLINE countVars #-}

applyMut :: MutationCfg -> Individual -> (MutationCfg -> TIR -> Rnd TIR) -> Rnd Individual
applyMut :: MutationCfg
-> Individual -> (MutationCfg -> TIR -> Rnd TIR) -> Rnd Individual
applyMut MutationCfg
params Individual
x MutationCfg -> TIR -> Rnd TIR
mut = do
  TIR
t <- MutationCfg -> TIR -> Rnd TIR
mut MutationCfg
params (Individual -> TIR
_chromo Individual
x)
  Individual -> Rnd Individual
forall (f :: * -> *) a. Applicative f => a -> f a
pure Individual
x{ _chromo :: TIR
_chromo=TIR
t, _fit :: [Double]
_fit=[] }

-- | Multi-mutation, it applies one of the following mutations at random:
--
-- * insertNode
-- * removeNode
-- * changeVar
-- * changeExponent
-- * changeFun
multiMut :: MutationCfg -> Individual -> Rnd Individual
multiMut :: MutationCfg -> Individual -> Rnd Individual
multiMut MutationCfg
params Individual
x = do
  let (TIR Function
_ Sigma
p Sigma
q) = Individual -> TIR
_chromo Individual
x
  MutationCfg -> TIR -> Rnd TIR
mut <- if Sigma -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Sigma
p Bool -> Bool -> Bool
&& Sigma -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Sigma
q
          then [MutationCfg -> TIR -> Rnd TIR]
-> Rnd (MutationCfg -> TIR -> Rnd TIR)
forall a. [a] -> Rnd a
randomFrom [MutationCfg -> TIR -> Rnd TIR
insertNode]
          else if Sigma -> Int
countVars Sigma
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Sigma -> Int
countVars Sigma
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutationCfg -> Int
_budget MutationCfg
params
                 then [MutationCfg -> TIR -> Rnd TIR]
-> Rnd (MutationCfg -> TIR -> Rnd TIR)
forall a. [a] -> Rnd a
randomFrom [MutationCfg -> TIR -> Rnd TIR
removeNode, MutationCfg -> TIR -> Rnd TIR
changeVar, MutationCfg -> TIR -> Rnd TIR
changeExponent, MutationCfg -> TIR -> Rnd TIR
changeFun]
                 else [MutationCfg -> TIR -> Rnd TIR]
-> Rnd (MutationCfg -> TIR -> Rnd TIR)
forall a. [a] -> Rnd a
randomFrom [MutationCfg -> TIR -> Rnd TIR
insertNode, MutationCfg -> TIR -> Rnd TIR
removeNode, MutationCfg -> TIR -> Rnd TIR
changeVar, MutationCfg -> TIR -> Rnd TIR
changeExponent, MutationCfg -> TIR -> Rnd TIR
changeFun]
  MutationCfg
-> Individual -> (MutationCfg -> TIR -> Rnd TIR) -> Rnd Individual
applyMut MutationCfg
params Individual
x MutationCfg -> TIR -> Rnd TIR
mut

-- | inserts a random node
insertNode :: MutationCfg -> TIR -> Rnd TIR
insertNode :: MutationCfg -> TIR -> Rnd TIR
insertNode MutationCfg
params (TIR Function
g Sigma
p Sigma
q) 
  | Sigma -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Sigma
p Bool -> Bool -> Bool
&& Sigma -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Sigma
q = Rnd TIR
insertTerm
  | Bool
otherwise        = Rnd TIR -> Rnd TIR -> Rnd TIR
forall a. Rnd a -> Rnd a -> Rnd a
randomChoice Rnd TIR
insertVar Rnd TIR
insertTerm
  where
    insertVar :: Rnd TIR
insertVar = do
      let np :: Int
np = Sigma -> Int
countVars Sigma
p
          nq :: Int
nq = Sigma -> Int
countVars Sigma
q
      Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      Int
k  <- (Int, Int) -> Rnd Int
randomRngNZ ((Int, Int) -> Rnd Int) -> (Int, Int) -> Rnd Int
forall a b. (a -> b) -> a -> b
$ MutationCfg -> (Int, Int)
_kRange MutationCfg
params 
      if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
         then do (Maybe Int
var, MutationCfg
_) <- MutationCfg -> Rnd (Maybe Int, MutationCfg)
randomVar MutationCfg
params
                 case Maybe Int
var of
                   Maybe Int
Nothing -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q)
                   Just Int
v  -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g (Int -> Sigma -> (Int, Int) -> Sigma
insertInto Int
ix Sigma
p (Int
v,Int
k)) Sigma
q)
         else do (Maybe Int
var, MutationCfg
_) <- MutationCfg -> Rnd (Maybe Int, MutationCfg)
randomVar MutationCfg
params
                 case Maybe Int
var of
                   Maybe Int
Nothing -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q)
                   Just Int
v  -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p (Int -> Sigma -> (Int, Int) -> Sigma
insertInto (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
np) Sigma
q (Int
v,Int
k)))
    insertTerm :: Rnd TIR
insertTerm = do
      let np :: Int
np = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
p
          nq :: Int
nq = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
q
      Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
         then do Maybe Pi
mp <- MutationCfg -> Rnd (Maybe Pi)
randomPi MutationCfg
params
                 case Maybe Pi
mp of
                   Maybe Pi
Nothing -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q)
                   Just Pi
p' -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g (Pi
p'Pi -> Sigma -> Sigma
forall a. a -> [a] -> [a]
:Sigma
p) Sigma
q)
         else do Maybe Pi
mq <- MutationCfg -> Rnd (Maybe Pi)
randomPi MutationCfg
params
                 case Maybe Pi
mq of
                   Maybe Pi
Nothing -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q)
                   Just Pi
q' -> TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p (Pi
q'Pi -> Sigma -> Sigma
forall a. a -> [a] -> [a]
:Sigma
q))
    
    insertInto :: Int -> Sigma -> (Int, Int) -> Sigma
insertInto Int
ix  []    (Int, Int)
_ = [Char] -> Sigma
forall a. HasCallStack => [Char] -> a
error [Char]
"Incorrect index in insertVar"
    insertInto Int
0  (Pi
x:Sigma
xs) (Int, Int)
y = Pi -> (Int, Int) -> Pi
forall {a} {a} {b}. Eq a => (a, b, [a]) -> a -> (a, b, [a])
appendVar Pi
x (Int, Int)
y Pi -> Sigma -> Sigma
forall a. a -> [a] -> [a]
: Sigma
xs
    insertInto Int
ix (Pi
x:Sigma
xs) (Int, Int)
y = let nvars :: Int
nvars = [(Int, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Pi -> [(Int, Int)]
trd Pi
x)
                             in  if Int
nvars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
ix
                                  then Pi -> (Int, Int) -> Pi
forall {a} {a} {b}. Eq a => (a, b, [a]) -> a -> (a, b, [a])
appendVar Pi
x (Int, Int)
y Pi -> Sigma -> Sigma
forall a. a -> [a] -> [a]
: Sigma
xs
                                  else Pi
x Pi -> Sigma -> Sigma
forall a. a -> [a] -> [a]
: Int -> Sigma -> (Int, Int) -> Sigma
insertInto (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nvars) Sigma
xs (Int, Int)
y
    appendVar :: (a, b, [a]) -> a -> (a, b, [a])
appendVar (a
x, b
y, [a]
z) a
z' = if a
z' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
z then (a
x, b
y, [a]
z) else (a
x, b
y, a
z'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
z)

-- | removes a random node
removeNode :: MutationCfg -> TIR -> Rnd TIR
removeNode :: MutationCfg -> TIR -> Rnd TIR
removeNode MutationCfg
params (TIR Function
g Sigma
p Sigma
q) = Rnd TIR -> Rnd TIR -> Rnd TIR
forall a. Rnd a -> Rnd a -> Rnd a
randomChoice Rnd TIR
removeVar Rnd TIR
removeTerm
  where
    removeVar :: Rnd TIR
removeVar = do
      let np :: Int
np = Sigma -> Int
countVars Sigma
p
          nq :: Int
nq = Sigma -> Int
countVars Sigma
q
      Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
         then if Int
np Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q) else TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g (Int -> Sigma -> Sigma
forall {a} {b} {a}. Int -> [(a, b, [a])] -> [(a, b, [a])]
removeVarAt Int
ix Sigma
p) Sigma
q) 
         else TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p (Int -> Sigma -> Sigma
forall {a} {b} {a}. Int -> [(a, b, [a])] -> [(a, b, [a])]
removeVarAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
np) Sigma
q))
    removeTerm :: Rnd TIR
removeTerm = do
      let np :: Int
np = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
p
          nq :: Int
nq = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
q
      Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
      if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
         then if Int
np Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q) else TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g (Int -> Sigma -> Sigma
forall {a}. Int -> [a] -> [a]
removeAt Int
ix Sigma
p) Sigma
q)
         else TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p (Int -> Sigma -> Sigma
forall {a}. Int -> [a] -> [a]
removeAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
np) Sigma
q))

    removeAt :: Int -> [a] -> [a]
removeAt Int
ix [a]
xs         = Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
take Int
ix [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
drop (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
xs
    removeVarAt :: Int -> [(a, b, [a])] -> [(a, b, [a])]
removeVarAt Int
ix []            = []
    removeVarAt Int
ix ((a
a,b
b,[a]
c):[(a, b, [a])]
xs)  = let nvars :: Int
nvars = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
c
                                   in if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nvars
                                       then if Int
nvars Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                                             then [(a, b, [a])]
xs
                                             else (a
a, b
b, Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
removeAt Int
ix [a]
c) (a, b, [a]) -> [(a, b, [a])] -> [(a, b, [a])]
forall a. a -> [a] -> [a]
: [(a, b, [a])]
xs
                                       else (a
a,b
b,[a]
c) (a, b, [a]) -> [(a, b, [a])] -> [(a, b, [a])]
forall a. a -> [a] -> [a]
: Int -> [(a, b, [a])] -> [(a, b, [a])]
removeVarAt (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nvars) [(a, b, [a])]
xs

-- | changes the index of a random variable node.
changeVar :: MutationCfg -> TIR -> Rnd TIR
changeVar :: MutationCfg -> TIR -> Rnd TIR
changeVar MutationCfg
params (TIR Function
g Sigma
p Sigma
q) = do
  let np :: Int
np = Sigma -> Int
countVars Sigma
p
      nq :: Int
nq = Sigma -> Int
countVars Sigma
q
  Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
    then do Sigma
p' <- Int -> Sigma -> StateT StdGen IO Sigma
forall {a} {b} {b}.
Int
-> [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
changeVarAt Int
ix Sigma
p
            TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p' Sigma
q)
    else do Sigma
q' <- Int -> Sigma -> StateT StdGen IO Sigma
forall {a} {b} {b}.
Int
-> [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
changeVarAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
np) Sigma
q
            TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q')
  where
    
    changeVarAt :: Int
-> [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
changeVarAt Int
ix [] = [Char] -> StateT StdGen IO [(a, b, [(Int, b)])]
forall a. HasCallStack => [Char] -> a
error ([Char] -> StateT StdGen IO [(a, b, [(Int, b)])])
-> [Char] -> StateT StdGen IO [(a, b, [(Int, b)])]
forall a b. (a -> b) -> a -> b
$ [Char]
"changeVarAt sampled something wrong" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Sigma -> [Char]
forall a. Show a => a -> [Char]
show Sigma
p [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Sigma -> [Char]
forall a. Show a => a -> [Char]
show Sigma
q [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ix
    changeVarAt Int
ix ((a
w,b
x,[(Int, b)]
ys):[(a, b, [(Int, b)])]
xs)
      | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Int, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, b)]
ys = do [(Int, b)]
ys' <- Int -> [(Int, b)] -> StateT StdGen IO [(Int, b)]
forall {b}. Int -> [(Int, b)] -> StateT StdGen IO [(Int, b)]
changeElemAt Int
ix [(Int, b)]
ys
                            [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])])
-> [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
forall a b. (a -> b) -> a -> b
$ (a
w,b
x,[(Int, b)]
ys')(a, b, [(Int, b)]) -> [(a, b, [(Int, b)])] -> [(a, b, [(Int, b)])]
forall a. a -> [a] -> [a]
:[(a, b, [(Int, b)])]
xs
      | Bool
otherwise      = ((a
w,b
x,[(Int, b)]
ys) (a, b, [(Int, b)]) -> [(a, b, [(Int, b)])] -> [(a, b, [(Int, b)])]
forall a. a -> [a] -> [a]
:) ([(a, b, [(Int, b)])] -> [(a, b, [(Int, b)])])
-> StateT StdGen IO [(a, b, [(Int, b)])]
-> StateT StdGen IO [(a, b, [(Int, b)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [(a, b, [(Int, b)])] -> StateT StdGen IO [(a, b, [(Int, b)])]
changeVarAt (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(Int, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, b)]
ys) [(a, b, [(Int, b)])]
xs
    changeElemAt :: Int -> [(Int, b)] -> StateT StdGen IO [(Int, b)]
changeElemAt Int
ix [(Int, b)]
ys = do let y :: (Int, b)
y  = [(Int, b)]
ys [(Int, b)] -> Int -> (Int, b)
forall a. [a] -> Int -> a
!! Int
ix
                                vs :: [Int]
vs = MutationCfg -> [Int]
_vars MutationCfg
params [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((Int, b) -> Int) -> [(Int, b)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, b) -> Int
forall a b. (a, b) -> a
fst [(Int, b)]
ys
                            if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
vs
                              then [(Int, b)] -> StateT StdGen IO [(Int, b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Int, b)]
ys
                              else do Int
v' <- [Int] -> Rnd Int
forall a. [a] -> Rnd a
randomFrom [Int]
vs
                                      [(Int, b)] -> StateT StdGen IO [(Int, b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Int, b)] -> StateT StdGen IO [(Int, b)])
-> [(Int, b)] -> StateT StdGen IO [(Int, b)]
forall a b. (a -> b) -> a -> b
$ Int -> [(Int, b)] -> [(Int, b)]
forall {a}. Int -> [a] -> [a]
take Int
ix [(Int, b)]
ys [(Int, b)] -> [(Int, b)] -> [(Int, b)]
forall a. [a] -> [a] -> [a]
++ ((Int
v', (Int, b) -> b
forall a b. (a, b) -> b
snd (Int, b)
y) (Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
: Int -> [(Int, b)] -> [(Int, b)]
forall {a}. Int -> [a] -> [a]
drop (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(Int, b)]
ys)

-- | changes a random exponent.
changeExponent :: MutationCfg -> TIR -> Rnd TIR
changeExponent :: MutationCfg -> TIR -> Rnd TIR
changeExponent MutationCfg
params (TIR Function
g Sigma
p Sigma
q) = do
  let np :: Int
np = Sigma -> Int
countVars Sigma
p
      nq :: Int
nq = Sigma -> Int
countVars Sigma
q
  Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
np
    then do Sigma
p' <- Int -> Sigma -> StateT StdGen IO Sigma
forall {a} {b} {a}.
Int
-> [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
changeVarAt Int
ix Sigma
p
            TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p' Sigma
q)
    else do Sigma
q' <- Int -> Sigma -> StateT StdGen IO Sigma
forall {a} {b} {a}.
Int
-> [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
changeVarAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
np) Sigma
q
            TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p Sigma
q')
  where
    
    changeVarAt :: Int
-> [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
changeVarAt Int
ix [] = [Char] -> StateT StdGen IO [(a, b, [(a, Int)])]
forall a. HasCallStack => [Char] -> a
error [Char]
"changeExp sampled something wrong"
    changeVarAt Int
ix ((a
w,b
x,[(a, Int)]
ys):[(a, b, [(a, Int)])]
xs)
      | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(a, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Int)]
ys = do [(a, Int)]
ys' <- Int -> [(a, Int)] -> StateT StdGen IO [(a, Int)]
forall {a}. Int -> [(a, Int)] -> StateT StdGen IO [(a, Int)]
changeElemAt Int
ix [(a, Int)]
ys
                            [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])])
-> [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
forall a b. (a -> b) -> a -> b
$ (a
w,b
x,[(a, Int)]
ys')(a, b, [(a, Int)]) -> [(a, b, [(a, Int)])] -> [(a, b, [(a, Int)])]
forall a. a -> [a] -> [a]
:[(a, b, [(a, Int)])]
xs
      | Bool
otherwise      = ((a
w,b
x,[(a, Int)]
ys) (a, b, [(a, Int)]) -> [(a, b, [(a, Int)])] -> [(a, b, [(a, Int)])]
forall a. a -> [a] -> [a]
:) ([(a, b, [(a, Int)])] -> [(a, b, [(a, Int)])])
-> StateT StdGen IO [(a, b, [(a, Int)])]
-> StateT StdGen IO [(a, b, [(a, Int)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> [(a, b, [(a, Int)])] -> StateT StdGen IO [(a, b, [(a, Int)])]
changeVarAt (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- [(a, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Int)]
ys) [(a, b, [(a, Int)])]
xs
    changeElemAt :: Int -> [(a, Int)] -> StateT StdGen IO [(a, Int)]
changeElemAt Int
ix [(a, Int)]
ys = do let y :: (a, Int)
y  = [(a, Int)]
ys [(a, Int)] -> Int -> (a, Int)
forall a. [a] -> Int -> a
!! Int
ix
                            Int
k <- (Int, Int) -> Rnd Int
randomRngNZ ((Int, Int) -> Rnd Int) -> (Int, Int) -> Rnd Int
forall a b. (a -> b) -> a -> b
$ MutationCfg -> (Int, Int)
_kRange MutationCfg
params
                            [(a, Int)] -> StateT StdGen IO [(a, Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, Int)] -> StateT StdGen IO [(a, Int)])
-> [(a, Int)] -> StateT StdGen IO [(a, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [(a, Int)] -> [(a, Int)]
forall {a}. Int -> [a] -> [a]
take Int
ix [(a, Int)]
ys [(a, Int)] -> [(a, Int)] -> [(a, Int)]
forall a. [a] -> [a] -> [a]
++ (((a, Int) -> a
forall a b. (a, b) -> a
fst (a, Int)
y, Int
k) (a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
: Int -> [(a, Int)] -> [(a, Int)]
forall {a}. Int -> [a] -> [a]
drop (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(a, Int)]
ys)

-- | changes a random transformation function.
changeFun :: MutationCfg -> TIR -> Rnd TIR
changeFun :: MutationCfg -> TIR -> Rnd TIR
changeFun MutationCfg
params (TIR Function
g Sigma
p Sigma
q) = do
  let np :: Int
np = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
p
      nq :: Int
nq = Sigma -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sigma
q
  Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nq)
  Function
g' <- [Function] -> Rnd Function
forall a. [a] -> Rnd a
randomFrom (MutationCfg -> [Function]
_yfuns MutationCfg
params)
  Function
f' <- [Function] -> Rnd Function
forall a. [a] -> Rnd a
randomFrom (MutationCfg -> [Function]
_funs MutationCfg
params)
  if Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g' Sigma
p Sigma
q)
    else if Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
np
           then TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g (Int -> Sigma -> Function -> Sigma
forall {t} {a} {t} {c}.
(Eq t, Num t) =>
t -> [(a, t, c)] -> t -> [(a, t, c)]
changeFunAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Sigma
p Function
f') Sigma
q)
           else TIR -> Rnd TIR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function -> Sigma -> Sigma -> TIR
TIR Function
g Sigma
p (Int -> Sigma -> Function -> Sigma
forall {t} {a} {t} {c}.
(Eq t, Num t) =>
t -> [(a, t, c)] -> t -> [(a, t, c)]
changeFunAt (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
np) Sigma
q Function
f'))
  where
    changeFunAt :: t -> [(a, t, c)] -> t -> [(a, t, c)]
changeFunAt t
_  []            t
h' = [Char] -> [(a, t, c)]
forall a. HasCallStack => [Char] -> a
error [Char]
"Wrong indice sampled from changeFun"
    changeFunAt t
0  ((a
w,t
h,c
ys):[(a, t, c)]
xs) t
h' = (a
w,t
h',c
ys) (a, t, c) -> [(a, t, c)] -> [(a, t, c)]
forall a. a -> [a] -> [a]
: [(a, t, c)]
xs
    changeFunAt t
ix ((a
w,t
h,c
ys):[(a, t, c)]
xs) t
h' = (a
w,t
h,c
ys)  (a, t, c) -> [(a, t, c)] -> [(a, t, c)]
forall a. a -> [a] -> [a]
: t -> [(a, t, c)] -> t -> [(a, t, c)]
changeFunAt (t
ixt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [(a, t, c)]
xs t
h' 

-- | replaces a subtree at random (not yet implemented).
replaceSubTree :: MutationCfg -> TIR -> Rnd TIR
replaceSubTree :: MutationCfg -> TIR -> Rnd TIR
replaceSubTree = MutationCfg -> TIR -> Rnd TIR
forall a. HasCallStack => a
undefined