-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Test utilities for pig images.
--
-----------------------------------------------------------------------------


{-# LANGUAGE FlexibleContexts #-}


module Pigy.Image.Test (
-- * Testing
  test
, testCreate
, testCrossover
, testTree
, testVersion
) where


import Control.Monad          (replicateM)
import Pigy.Image             (Genotype(..), crossover, fromChromosome, toChromosome, writeImage)
import Pigy.Image.Types       (Phenable(..), Upgradeable(..))
import System.Random          (getStdGen)
import System.Random.Internal (uniformM)
import System.Random.Stateful (StatefulGen, newIOGenM)


-- | Run all tests.
test :: IO ()
test :: IO ()
test =
  do
    IOGenM StdGen
g <- StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM (StdGen -> IO (IOGenM StdGen)) -> IO StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
    IOGenM StdGen -> IO ()
forall g. StatefulGen g IO => g -> IO ()
testCreate IOGenM StdGen
g
    IOGenM StdGen -> IO ()
forall g. StatefulGen g IO => g -> IO ()
testCrossover IOGenM StdGen
g
    IOGenM StdGen -> IO ()
forall g. StatefulGen g IO => g -> IO ()
testVersion IOGenM StdGen
g
    IOGenM StdGen -> IO ()
forall g. StatefulGen g IO => g -> IO ()
testTree IOGenM StdGen
g


-- | Test image creation.
testCreate :: StatefulGen g IO
           => g     -- ^ The random-number generator.
           -> IO () -- ^ Action for running the test.
testCreate :: g -> IO ()
testCreate g
g =
  do
    Genotype
genotype <- g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    let
      chromosome :: Chromosome
chromosome = Genotype -> Chromosome
toChromosome Genotype
genotype
      Just Genotype
genotype' = Chromosome -> Maybe Genotype
fromChromosome Chromosome
chromosome
      phenotype :: Phenotype
phenotype = Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
genotype'
      Just Genotype
genotype'' = Chromosome -> Maybe Genotype
fromChromosome (Chromosome -> Maybe Genotype) -> Chromosome -> Maybe Genotype
forall a b. (a -> b) -> a -> b
$ Genotype -> Chromosome
toChromosome Genotype
genotype'
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage (Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
chromosome Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png") Phenotype
phenotype
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Chromosome: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
chromosome
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Before encoding: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
genotype
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"After encoding: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
genotype'
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Encoding okay: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Bool -> Chromosome
forall a. Show a => a -> Chromosome
show (Genotype
genotype' Genotype -> Genotype -> Bool
forall a. Eq a => a -> a -> Bool
== Genotype
genotype'')


-- | Test crossover.
testCrossover :: StatefulGen g IO
              => g     -- ^ The random-number generator.
              -> IO () -- ^ Action for running the test.
testCrossover :: g -> IO ()
testCrossover g
g =
  do
    Genotype
parent  <- g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    Genotype
parent' <- g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    Genotype
offspring <- g -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover g
g [Genotype
parent, Genotype
parent']
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Parent 1: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
parent
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Parent 2: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
parent'
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Offsping: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
offspring
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-parent-1.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
parent
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-parent-2.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
parent'
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-offspring.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
offspring


-- | Test versioning.
testVersion :: StatefulGen g IO
            => g     -- ^ The random-number generator.
            -> IO () -- ^ Action for running the test.
testVersion :: g -> IO ()
testVersion g
g =
  do
    Genotype
genotype <- Genotype -> Genotype
GenotypeV0 (Genotype -> Genotype) -> IO Genotype -> IO Genotype
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    let
      chromosome :: Chromosome
chromosome = Genotype -> Chromosome
toChromosome Genotype
genotype
      Just Genotype
genotype' = Chromosome -> Maybe Genotype
fromChromosome Chromosome
chromosome
      phenotype :: Phenotype
phenotype = Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
genotype'
      Just Genotype
genotype'' = Chromosome -> Maybe Genotype
fromChromosome (Chromosome -> Maybe Genotype) -> Chromosome -> Maybe Genotype
forall a b. (a -> b) -> a -> b
$ Genotype -> Chromosome
toChromosome Genotype
genotype'
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage (Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
chromosome Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png") Phenotype
phenotype
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Chromosome: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
chromosome
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Before encoding: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
genotype
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"After encoding: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
genotype'
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"After upgrade: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show (Genotype -> Genotype
forall g h. Upgradeable g h => g -> h
upgrade Genotype
genotype' :: Genotype)
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Encoding okay: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Bool -> Chromosome
forall a. Show a => a -> Chromosome
show (Genotype
genotype' Genotype -> Genotype -> Bool
forall a. Eq a => a -> a -> Bool
== Genotype
genotype'')
    Genotype
parent  <- Genotype -> Genotype
GenotypeV0 (Genotype -> Genotype) -> IO Genotype -> IO Genotype
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    Genotype
parent' <- g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g
    Genotype
offspring <- g -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover g
g [Genotype
parent, Genotype
parent']
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Parent 1: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
parent
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Parent 2: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
parent'
    Chromosome -> IO ()
putStrLn Chromosome
""
    Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"Offsping: " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Genotype -> Chromosome
forall a. Show a => a -> Chromosome
show Genotype
offspring
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-parent-1.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
parent
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-parent-2.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
parent'
    Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
"pigy-offspring.png"
      (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
offspring


-- | Test family trees.
testTree :: StatefulGen g IO
         => g     -- ^ The random-number generator.
         -> IO () -- ^ Action for running the test.
testTree :: g -> IO ()
testTree g
g =
  do
    Chromosome -> IO ()
putStrLn Chromosome
"digraph pigy {"
    [Genotype]
parents <- Int -> IO Genotype -> IO [Genotype]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
6 (g -> IO Genotype
forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM g
g)
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        do
          Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" [label=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\" labelloc=\"t\" shape=box image=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
filename Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\"]"
          Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
filename (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
parent
      |
        Genotype
parent <- [Genotype]
parents
      , let tag :: Chromosome
tag      =  Genotype -> Chromosome
toChromosome Genotype
parent
            filename :: Chromosome
filename = Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png"
      ]
    [Genotype]
children <-
      [IO Genotype] -> IO [Genotype]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [
          do
            Genotype
child <- g -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover g
g [Genotype
parent1, Genotype
parent2]
            let
              tag :: Chromosome
tag      =  Genotype -> Chromosome
toChromosome Genotype
child
              filename :: Chromosome
filename = Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png"
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" [label=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\" labelloc=\"t\" shape=box image=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
filename Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\"]"
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag1 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag2 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
            Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
filename (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
child
            Genotype -> IO Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return Genotype
child
        |
          (Genotype
parent1, Genotype
parent2) <- [Genotype] -> [Genotype] -> [(Genotype, Genotype)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Genotype] -> [Genotype]
forall a. [a] -> [a]
init [Genotype]
parents) ([Genotype] -> [Genotype]
forall a. [a] -> [a]
tail [Genotype]
parents)
        , let
            tag1 :: Chromosome
tag1 =  Genotype -> Chromosome
toChromosome Genotype
parent1
            tag2 :: Chromosome
tag2 =  Genotype -> Chromosome
toChromosome Genotype
parent2
        ]
    [Genotype]
grandchildren <-
      [IO Genotype] -> IO [Genotype]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [
          do
            Genotype
child <- g -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover g
g [Genotype
parent1, Genotype
parent2]
            let
              tag :: Chromosome
tag      =  Genotype -> Chromosome
toChromosome Genotype
child
              filename :: Chromosome
filename = Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png"
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" [label=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\" labelloc=\"t\" shape=box image=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
filename Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\"]"
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag1 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
            Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag2 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
            Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
filename (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
child
            Genotype -> IO Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return Genotype
child
        |
          (Genotype
parent1, Genotype
parent2) <- [Genotype] -> [Genotype] -> [(Genotype, Genotype)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Genotype] -> [Genotype]
forall a. [a] -> [a]
init [Genotype]
children) ([Genotype] -> [Genotype]
forall a. [a] -> [a]
tail [Genotype]
children)
        , let
            tag1 :: Chromosome
tag1 =  Genotype -> Chromosome
toChromosome Genotype
parent1
            tag2 :: Chromosome
tag2 =  Genotype -> Chromosome
toChromosome Genotype
parent2
        ]
    [IO Genotype] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [
        do
          Genotype
child <- g -> [Genotype] -> IO Genotype
forall (m :: * -> *) g.
(MonadFail m, StatefulGen g m) =>
g -> [Genotype] -> m Genotype
crossover g
g [Genotype
parent1, Genotype
parent2]
          let
            tag :: Chromosome
tag      =  Genotype -> Chromosome
toChromosome Genotype
child
            filename :: Chromosome
filename = Chromosome
"pigy-" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
".png"
          Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" [label=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\" labelloc=\"t\" shape=box image=\"" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
filename Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"\"]"
          Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag1 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
          Chromosome -> IO ()
putStrLn (Chromosome -> IO ()) -> Chromosome -> IO ()
forall a b. (a -> b) -> a -> b
$ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag2 Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
" -> " Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
"P_" Chromosome -> Chromosome -> Chromosome
forall a. [a] -> [a] -> [a]
++ Chromosome
tag
          Chromosome -> Phenotype -> IO ()
forall (m :: * -> *). MonadIO m => Chromosome -> Phenotype -> m ()
writeImage Chromosome
filename (Phenotype -> IO ()) -> Phenotype -> IO ()
forall a b. (a -> b) -> a -> b
$ Genotype -> Phenotype
forall g. Phenable g => g -> Phenotype
toPhenotype Genotype
child
          Genotype -> IO Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return Genotype
child
      |
        (Genotype
parent1, Genotype
parent2) <- [Genotype] -> [Genotype] -> [(Genotype, Genotype)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Genotype] -> [Genotype]
forall a. [a] -> [a]
init [Genotype]
grandchildren) ([Genotype] -> [Genotype]
forall a. [a] -> [a]
tail [Genotype]
grandchildren)
      , let
          tag1 :: Chromosome
tag1 =  Genotype -> Chromosome
toChromosome Genotype
parent1
          tag2 :: Chromosome
tag2 =  Genotype -> Chromosome
toChromosome Genotype
parent2
      ]
    Chromosome -> IO ()
putStrLn Chromosome
"}"