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

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

import MachineLearning.TIR
import Control.Evolution
import Control.Monad.State.Strict
import System.Random
import Data.List (nub, sort)

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 #-}

rndWithProb :: Double -> Rnd Bool
rndWithProb :: Double -> Rnd Bool
rndWithProb Double
p = (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
p) (Double -> Bool) -> StateT StdGen IO Double -> Rnd Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StdGen -> (Double, StdGen)) -> StateT StdGen IO Double
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state StdGen -> (Double, StdGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
{-# INLINE rndWithProb #-}

choose :: a -> a -> Bool -> a
choose :: forall a. a -> a -> Bool -> a
choose a
x a
y Bool
b = if Bool
b then a
x else a
y
{-# INLINE choose #-}

-- | One-point crossover
onepoint :: [Individual] -> Rnd Individual
onepoint :: [Individual] -> Rnd Individual
onepoint (Individual
p1:Individual
p2:[Individual]
_) = do
  Int
r <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int
npc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nqc1)
  if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
     then Rnd Individual
swapY
     else if Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [(Double, Function, [(Int, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Function, [(Int, Int)])]
pc1
            then Rnd Individual
swapP
            else Rnd Individual
swapQ
  where
    c1 :: TIR
c1    = Individual -> TIR
_chromo Individual
p1
    c2 :: TIR
c2    = Individual -> TIR
_chromo Individual
p2
    pc1 :: [(Double, Function, [(Int, Int)])]
pc1   = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
clean ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_p TIR
c1
    qc1 :: [(Double, Function, [(Int, Int)])]
qc1   = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
clean ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_q TIR
c1
    pc2 :: [(Double, Function, [(Int, Int)])]
pc2   = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
clean ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_p TIR
c2
    qc2 :: [(Double, Function, [(Int, Int)])]
qc2   = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
clean ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_q TIR
c2
    npc1 :: Int
npc1  = [(Double, Function, [(Int, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Function, [(Int, Int)])]
pc1
    nqc1 :: Int
nqc1  = [(Double, Function, [(Int, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Function, [(Int, Int)])]
qc1
    npc2 :: Int
npc2  = [(Double, Function, [(Int, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Function, [(Int, Int)])]
pc2
    nqc2 :: Int
nqc2  = [(Double, Function, [(Int, Int)])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Function, [(Int, Int)])]
qc2
    sortPi :: (a, b, [a]) -> (a, b, [a])
sortPi (a
x,b
y,[a]
z) = (a
x,b
y,[a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
z)
    clean :: [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
clean = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> ([(Double, Function, [(Int, Int)])]
    -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
forall {a} {a} {b}. Ord a => (a, b, [a]) -> (a, b, [a])
sortPi
    swapY :: Rnd Individual
swapY = Individual -> Rnd Individual
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Individual -> Rnd Individual) -> Individual -> Rnd Individual
forall a b. (a -> b) -> a -> b
$ Individual
p1{ _chromo :: TIR
_chromo = TIR
c1{ _p :: [(Double, Function, [(Int, Int)])]
_p=[(Double, Function, [(Int, Int)])]
pc1, _q :: [(Double, Function, [(Int, Int)])]
_q = [(Double, Function, [(Int, Int)])]
qc2 }, _fit :: [Double]
_fit = [] }
    swapP :: Rnd Individual
swapP = do Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
npc1 Int
npc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
               let pc' :: [(Double, Function, [(Int, Int)])]
pc' = Int
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Int -> [a] -> [a]
take Int
ix [(Double, Function, [(Int, Int)])]
pc1 [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Semigroup a => a -> a -> a
<> Int
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Int -> [a] -> [a]
drop Int
ix [(Double, Function, [(Int, Int)])]
pc2 
               Individual -> Rnd Individual
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Individual -> Rnd Individual) -> Individual -> Rnd Individual
forall a b. (a -> b) -> a -> b
$ Individual
p1{ _chromo :: TIR
_chromo = TIR
c1{ _p :: [(Double, Function, [(Int, Int)])]
_p = [(Double, Function, [(Int, Int)])]
pc', _q :: [(Double, Function, [(Int, Int)])]
_q = [(Double, Function, [(Int, Int)])]
qc1 }, _fit :: [Double]
_fit = [] }
    swapQ :: Rnd Individual
swapQ = do Int
ix <- (Int, Int) -> Rnd Int
randomRng (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
nqc1 Int
nqc2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
               let qc' :: [(Double, Function, [(Int, Int)])]
qc' = Int
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Int -> [a] -> [a]
take Int
ix [(Double, Function, [(Int, Int)])]
qc1 [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Semigroup a => a -> a -> a
<> Int
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Int -> [a] -> [a]
drop Int
ix [(Double, Function, [(Int, Int)])]
qc2 
               Individual -> Rnd Individual
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Individual -> Rnd Individual) -> Individual -> Rnd Individual
forall a b. (a -> b) -> a -> b
$ Individual
p1{ _chromo :: TIR
_chromo = TIR
c1{ _p :: [(Double, Function, [(Int, Int)])]
_p = [(Double, Function, [(Int, Int)])]
pc1, _q :: [(Double, Function, [(Int, Int)])]
_q = [(Double, Function, [(Int, Int)])]
qc' }, _fit :: [Double]
_fit = [] }
onepoint [Individual]
_         = [Char] -> Rnd Individual
forall a. HasCallStack => [Char] -> a
error [Char]
"Not enough individuals for onepoint crossover"
    
-- | Uniform crossover
uniformCx :: [Individual] -> Rnd Individual
uniformCx :: [Individual] -> Rnd Individual
uniformCx (Individual
p1:Individual
p2:[Individual]
_) = do
  let c1 :: TIR
c1   = Individual -> TIR
_chromo Individual
p1
      c2 :: TIR
c2   = Individual -> TIR
_chromo Individual
p2
      f1 :: Double
f1   = Individual -> Double
forall a. Solution a => a -> Double
_getFitness Individual
p1
      f2 :: Double
f2   = Individual -> Double
forall a. Solution a => a -> Double
_getFitness Individual
p2
      pc1 :: [(Double, Function, [(Int, Int)])]
pc1  = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
forall {a} {a} {b}. Ord a => (a, b, [a]) -> (a, b, [a])
sortPi ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_p TIR
c1
      pc2 :: [(Double, Function, [(Int, Int)])]
pc2  = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
forall {a} {a} {b}. Ord a => (a, b, [a]) -> (a, b, [a])
sortPi ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_p TIR
c2
      qc1 :: [(Double, Function, [(Int, Int)])]
qc1  = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
forall {a} {a} {b}. Ord a => (a, b, [a]) -> (a, b, [a])
sortPi ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_q TIR
c1
      qc2 :: [(Double, Function, [(Int, Int)])]
qc2  = [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
forall {a} {a} {b}. Ord a => (a, b, [a]) -> (a, b, [a])
sortPi ([(Double, Function, [(Int, Int)])]
 -> [(Double, Function, [(Int, Int)])])
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a b. (a -> b) -> a -> b
$ TIR -> [(Double, Function, [(Int, Int)])]
_q TIR
c2
      rnd1 :: Rnd Bool
rnd1 = Double -> Rnd Bool
rndWithProb (Double
f1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/(Double
f1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
f2))

      rndChoice :: b -> b -> StateT StdGen IO b
rndChoice b
x b
y = b -> b -> Bool -> b
forall a. a -> a -> Bool -> a
choose b
x b
y (Bool -> b) -> Rnd Bool -> StateT StdGen IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rnd Bool
rnd1
      sortPi :: (a, b, [a]) -> (a, b, [a])
sortPi (a
x,b
y,[a]
z) = (a
x,b
y,[a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
z)
  Function
g' <- Function -> Function -> StateT StdGen IO Function
forall {b}. b -> b -> StateT StdGen IO b
rndChoice (TIR -> Function
_funY TIR
c1) (TIR -> Function
_funY TIR
c2)
  [(Double, Function, [(Int, Int)])]
p' <- ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)])
 -> StateT StdGen IO (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
-> StateT StdGen IO [(Double, Function, [(Int, Int)])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
-> StateT StdGen IO (Double, Function, [(Int, Int)])
forall {b}. b -> b -> StateT StdGen IO b
rndChoice [(Double, Function, [(Int, Int)])]
pc1 [(Double, Function, [(Int, Int)])]
pc2
  [(Double, Function, [(Int, Int)])]
q' <- ((Double, Function, [(Int, Int)])
 -> (Double, Function, [(Int, Int)])
 -> StateT StdGen IO (Double, Function, [(Int, Int)]))
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
-> StateT StdGen IO [(Double, Function, [(Int, Int)])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Double, Function, [(Int, Int)])
-> (Double, Function, [(Int, Int)])
-> StateT StdGen IO (Double, Function, [(Int, Int)])
forall {b}. b -> b -> StateT StdGen IO b
rndChoice [(Double, Function, [(Int, Int)])]
qc1 [(Double, Function, [(Int, Int)])]
qc2

  let c :: TIR
c = Function
-> [(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
-> TIR
TIR Function
g' ([(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub [(Double, Function, [(Int, Int)])]
p') ([(Double, Function, [(Int, Int)])]
-> [(Double, Function, [(Int, Int)])]
forall a. Eq a => [a] -> [a]
nub [(Double, Function, [(Int, Int)])]
q')
  Individual -> Rnd Individual
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Individual -> Rnd Individual) -> Individual -> Rnd Individual
forall a b. (a -> b) -> a -> b
$ Individual
p1{ _chromo :: TIR
_chromo=TIR
c, _fit :: [Double]
_fit=[] }

uniformCx [Individual]
_ = [Char] -> Rnd Individual
forall a. HasCallStack => [Char] -> a
error [Char]
"Not enough individuals for uniform crossover"