-----------------------------------------------------------------------------
--
-- Module      :  $Headers
-- Copyright   :  (c) 2021 Brian W Bush
-- License     :  MIT
--
-- Maintainer  :  Brian W Bush <code@functionally.io>
-- Stability   :  Experimental
-- Portability :  Portable
--
-- | Version 1 of the pig-image genotype and phenotype.
--
-----------------------------------------------------------------------------


{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}


module Pigy.Image.V1 (
-- * Versioning
  gid
-- * Genetics
, Genotype(..)
, Phenotype(..)
, crossover
) where


import Codec.Picture            (PixelRGBA8(..))
import Control.Monad            (replicateM)
import Data.Binary              (Binary(..))
import Data.Colour.RGBSpace.HSL (hsl)
import Data.Colour.SRGB         (RGB(..))
import Data.Fixed               (mod')
import Data.Word                (Word8)
import Pigy.Image.Types         (Phenable(..), Phenotype(..), Upgradeable(..))
import System.Random            (Uniform)
import System.Random.Internal   (uniformM, uniformRM)
import System.Random.Stateful   (StatefulGen)


-- | The version of the genotype.
gid :: Word8
gid :: Word8
gid = Word8
1


-- | The genotype.
data Genotype =
  Genotype
  {
    Genotype -> Float
ar     :: Float -- ^ Aspect ratio.
  , Genotype -> Float
headx  :: Float -- ^ Head width.
  , Genotype -> Float
heady  :: Float -- ^ Head height.
  , Genotype -> Float
eyex   :: Float -- ^ Eye width.
  , Genotype -> Float
eyey   :: Float -- ^ Eye height.
  , Genotype -> Float
nosex  :: Float -- ^ Nose width.
  , Genotype -> Float
nosey  :: Float -- ^ Nose height.
  , Genotype -> Float
earx   :: Float -- ^ Ear width.
  , Genotype -> Float
eary   :: Float -- ^ Ear height.
  , Genotype -> Float
torso  :: Float -- ^ Torso size.
  , Genotype -> Float
skinh  :: Float -- ^ Skin hue.
  , Genotype -> Float
eyeh   :: Float -- ^ Eye hue.
  , Genotype -> Float
eyes   :: Float -- ^ Eye saturation.
  , Genotype -> Float
eyel   :: Float -- ^ Eye luminosity.
  , Genotype -> Float
pupilh :: Float -- ^ Pupil hue.
  , Genotype -> Float
pupils :: Float -- ^ Pupil saturation.
  , Genotype -> Float
pupill :: Float -- ^ Pupil luminosity.
  , Genotype -> Float
noseh  :: Float -- ^ Nose hue.
  , Genotype -> Float
noses  :: Float -- ^ Nose saturation.
  , Genotype -> Float
nosel  :: Float -- ^ Nose luminosity.
  , Genotype -> Float
eyea   :: Float -- ^ Pupil radial angle.
  , Genotype -> Float
eyef   :: Float -- ^ Pupil radial position.
  }
    deriving (Genotype -> Genotype -> Bool
(Genotype -> Genotype -> Bool)
-> (Genotype -> Genotype -> Bool) -> Eq Genotype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Genotype -> Genotype -> Bool
$c/= :: Genotype -> Genotype -> Bool
== :: Genotype -> Genotype -> Bool
$c== :: Genotype -> Genotype -> Bool
Eq, Eq Genotype
Eq Genotype
-> (Genotype -> Genotype -> Ordering)
-> (Genotype -> Genotype -> Bool)
-> (Genotype -> Genotype -> Bool)
-> (Genotype -> Genotype -> Bool)
-> (Genotype -> Genotype -> Bool)
-> (Genotype -> Genotype -> Genotype)
-> (Genotype -> Genotype -> Genotype)
-> Ord Genotype
Genotype -> Genotype -> Bool
Genotype -> Genotype -> Ordering
Genotype -> Genotype -> Genotype
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Genotype -> Genotype -> Genotype
$cmin :: Genotype -> Genotype -> Genotype
max :: Genotype -> Genotype -> Genotype
$cmax :: Genotype -> Genotype -> Genotype
>= :: Genotype -> Genotype -> Bool
$c>= :: Genotype -> Genotype -> Bool
> :: Genotype -> Genotype -> Bool
$c> :: Genotype -> Genotype -> Bool
<= :: Genotype -> Genotype -> Bool
$c<= :: Genotype -> Genotype -> Bool
< :: Genotype -> Genotype -> Bool
$c< :: Genotype -> Genotype -> Bool
compare :: Genotype -> Genotype -> Ordering
$ccompare :: Genotype -> Genotype -> Ordering
$cp1Ord :: Eq Genotype
Ord, ReadPrec [Genotype]
ReadPrec Genotype
Int -> ReadS Genotype
ReadS [Genotype]
(Int -> ReadS Genotype)
-> ReadS [Genotype]
-> ReadPrec Genotype
-> ReadPrec [Genotype]
-> Read Genotype
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Genotype]
$creadListPrec :: ReadPrec [Genotype]
readPrec :: ReadPrec Genotype
$creadPrec :: ReadPrec Genotype
readList :: ReadS [Genotype]
$creadList :: ReadS [Genotype]
readsPrec :: Int -> ReadS Genotype
$creadsPrec :: Int -> ReadS Genotype
Read, Int -> Genotype -> ShowS
[Genotype] -> ShowS
Genotype -> String
(Int -> Genotype -> ShowS)
-> (Genotype -> String) -> ([Genotype] -> ShowS) -> Show Genotype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Genotype] -> ShowS
$cshowList :: [Genotype] -> ShowS
show :: Genotype -> String
$cshow :: Genotype -> String
showsPrec :: Int -> Genotype -> ShowS
$cshowsPrec :: Int -> Genotype -> ShowS
Show)

instance Upgradeable Genotype Genotype where
  upgrade :: Genotype -> Genotype
upgrade = Genotype -> Genotype
forall a. a -> a
id

instance Phenable Genotype where
  toPhenotype :: Genotype -> Phenotype
toPhenotype Genotype{Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
torso :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
ar :: Float
eyef :: Genotype -> Float
eyea :: Genotype -> Float
nosel :: Genotype -> Float
noses :: Genotype -> Float
noseh :: Genotype -> Float
pupill :: Genotype -> Float
pupils :: Genotype -> Float
pupilh :: Genotype -> Float
eyel :: Genotype -> Float
eyes :: Genotype -> Float
eyeh :: Genotype -> Float
skinh :: Genotype -> Float
torso :: Genotype -> Float
eary :: Genotype -> Float
earx :: Genotype -> Float
nosey :: Genotype -> Float
nosex :: Genotype -> Float
eyey :: Genotype -> Float
eyex :: Genotype -> Float
heady :: Genotype -> Float
headx :: Genotype -> Float
ar :: Genotype -> Float
..} =
    let
      hsl2rgb :: a -> a -> a -> PixelRGBA8
hsl2rgb a
h a
s a
l =
        let
          RGB{a
channelRed :: forall a. RGB a -> a
channelGreen :: forall a. RGB a -> a
channelBlue :: forall a. RGB a -> a
channelBlue :: a
channelGreen :: a
channelRed :: a
..} = a -> a -> a -> RGB a
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsl a
h a
s a
l
          q :: a -> b
q a
x = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
255 a -> a -> a
forall a. Num a => a -> a -> a
* a
x
        in
          Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 (a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
q a
channelRed) (a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
q a
channelGreen) (a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
q a
channelBlue) Word8
0xFF
      skinHue :: Float
skinHue     = Float
skinh
      eyeColor :: PixelRGBA8
eyeColor    = Float -> Float -> Float -> PixelRGBA8
forall a. RealFrac a => a -> a -> a -> PixelRGBA8
hsl2rgb Float
eyeh  Float
eyes  Float
eyel
      pupilColor :: PixelRGBA8
pupilColor  = Float -> Float -> Float -> PixelRGBA8
forall a. RealFrac a => a -> a -> a -> PixelRGBA8
hsl2rgb Float
pupilh Float
pupils Float
pupill
      noseColor :: PixelRGBA8
noseColor   = Float -> Float -> Float -> PixelRGBA8
forall a. RealFrac a => a -> a -> a -> PixelRGBA8
hsl2rgb Float
noseh  Float
noses  Float
nosel
      aspect :: Float
aspect      = Float
ar
      headScale :: (Float, Float)
headScale   = (Float
headx, Float
heady)
      eyeScale :: (Float, Float)
eyeScale    = (Float
eyex , Float
eyey )
      noseScale :: (Float, Float)
noseScale   = (Float
nosex, Float
nosey)
      earScale :: (Float, Float)
earScale    = (Float
earx , Float
eary )
      bodyScale :: Float
bodyScale   = Float
torso
      eyeAngle :: Float
eyeAngle    = Float
eyea Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
forall a. Floating a => a
pi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
180
      eyeFraction :: Float
eyeFraction = Float
eyef
    in
      Phenotype :: Float
-> PixelRGBA8
-> PixelRGBA8
-> PixelRGBA8
-> Float
-> (Float, Float)
-> (Float, Float)
-> (Float, Float)
-> (Float, Float)
-> Float
-> Float
-> Float
-> Phenotype
Phenotype{Float
(Float, Float)
PixelRGBA8
eyeFraction :: Float
eyeAngle :: Float
bodyScale :: Float
earScale :: (Float, Float)
noseScale :: (Float, Float)
eyeScale :: (Float, Float)
headScale :: (Float, Float)
aspect :: Float
noseColor :: PixelRGBA8
pupilColor :: PixelRGBA8
eyeColor :: PixelRGBA8
skinHue :: Float
eyeFraction :: Float
eyeAngle :: Float
bodyScale :: Float
earScale :: (Float, Float)
noseScale :: (Float, Float)
eyeScale :: (Float, Float)
headScale :: (Float, Float)
aspect :: Float
noseColor :: PixelRGBA8
pupilColor :: PixelRGBA8
eyeColor :: PixelRGBA8
skinHue :: Float
..}

instance Binary Genotype where
  put :: Genotype -> Put
put Genotype{Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
torso :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
ar :: Float
eyef :: Genotype -> Float
eyea :: Genotype -> Float
nosel :: Genotype -> Float
noses :: Genotype -> Float
noseh :: Genotype -> Float
pupill :: Genotype -> Float
pupils :: Genotype -> Float
pupilh :: Genotype -> Float
eyel :: Genotype -> Float
eyes :: Genotype -> Float
eyeh :: Genotype -> Float
skinh :: Genotype -> Float
torso :: Genotype -> Float
eary :: Genotype -> Float
earx :: Genotype -> Float
nosey :: Genotype -> Float
nosex :: Genotype -> Float
eyey :: Genotype -> Float
eyex :: Genotype -> Float
heady :: Genotype -> Float
headx :: Genotype -> Float
ar :: Genotype -> Float
..} =
    do
      let
        quantize :: (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
        quantize :: (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
x0, Float
x1) Float
x (Float
y0, Float
y1) Float
y =
          let
            hi :: Word8
hi = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Word8) -> Float -> Word8
forall a b. (a -> b) -> a -> b
$ Float
15 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0)
            lo :: Word8
lo = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Word8) -> Float -> Word8
forall a b. (a -> b) -> a -> b
$ Float
15 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0)
          in
            Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
hi Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
lo
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.75, Float
1.25) Float
ar     (Float
0.75, Float
1.25) Float
torso
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.75, Float
1.00) Float
headx  (Float
0.75, Float
1.00) Float
heady
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.75, Float
1.00) Float
eyex   (Float
0.75, Float
1.00) Float
eyey
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.75, Float
1.00) Float
nosex  (Float
0.75, Float
1.00) Float
nosey
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.75, Float
1.00) Float
earx   (Float
0.75, Float
1.00) Float
eary
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0   , Float
360 ) Float
skinh  (Float
0   , Float
360 ) Float
eyeh   
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.80, Float
1.00) Float
eyes   (Float
0.65, Float
1.00) Float
eyel   
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0   , Float
360 ) Float
pupilh (Float
0.80, Float
1.00) Float
pupils
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.00, Float
0.35) Float
pupill (Float
0   , Float
360 ) Float
noseh  
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0.80, Float
1.00) Float
noses  (Float
0.00, Float
0.40) Float
nosel  
      Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> Float -> (Float, Float) -> Float -> Word8
quantize (Float
0   , Float
360 ) Float
eyea   (Float
0.2 , Float
1   ) Float
eyef
  get :: Get Genotype
get =
    do
      let
        unquantize :: (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
        unquantize :: (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
x0, Float
x1) (Float
y0, Float
y1) Word8
w =
          let
            (Word8
hi, Word8
lo) = Word8
w Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
16
          in
            (
              Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
x1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x0) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hi Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
15
            , Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
y1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y0) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lo Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
15
            )
      (Float
ar    , Float
torso ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.75, Float
1.25) (Float
0.75, Float
1.25) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      (Float
headx , Float
heady ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.75, Float
1.00) (Float
0.75, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      (Float
eyex  , Float
eyey  ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.75, Float
1.00) (Float
0.75, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      (Float
nosex , Float
nosey ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.75, Float
1.00) (Float
0.75, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      (Float
earx  , Float
eary  ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.75, Float
1.00) (Float
0.75, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      (Float
skinh , Float
eyeh  ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0   , Float
360 ) (Float
0   , Float
360 ) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get 
      (Float
eyes  , Float
eyel  ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.80, Float
1.00) (Float
0.65, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get 
      (Float
pupilh, Float
pupils) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0   , Float
360 ) (Float
0.80, Float
1.00) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get 
      (Float
pupill, Float
noseh ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.00, Float
0.35) (Float
0   , Float
360 ) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get 
      (Float
noses , Float
nosel ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0.80, Float
1.00) (Float
0.00, Float
0.40) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get 
      (Float
eyea  , Float
eyef  ) <- (Float, Float) -> (Float, Float) -> Word8 -> (Float, Float)
unquantize (Float
0   , Float
360 ) (Float
0.2 , Float
1   ) (Word8 -> (Float, Float)) -> Get Word8 -> Get (Float, Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
forall t. Binary t => Get t
get
      Genotype -> Get Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return Genotype :: Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Genotype
Genotype{Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
torso :: Float
ar :: Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
torso :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
ar :: Float
..}

instance Uniform Genotype where
  uniformM :: g -> m Genotype
uniformM g
g =
    do
      Float
ar     <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.25) g
g
      Float
torso  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.25) g
g
      Float
headx  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
heady  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
eyex   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
eyey   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
nosex  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
nosey  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
earx   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
eary   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.75, Float
1.00) g
g
      Float
skinh  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0   , Float
360 ) g
g
      Float
eyeh   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0   , Float
360 ) g
g
      Float
eyes   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.80, Float
1.00) g
g
      Float
eyel   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.65, Float
1.00) g
g
      Float
pupilh <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0   , Float
360 ) g
g
      Float
pupils <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.80, Float
1.00) g
g
      Float
pupill <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.00, Float
0.35) g
g
      Float
noseh  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0   , Float
360 ) g
g
      Float
noses  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.80, Float
1.00) g
g
      Float
nosel  <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.00, Float
0.40) g
g
      Float
eyea   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0   , Float
360 ) g
g
      Float
eyef   <- (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0.2 , Float
1   ) g
g
      Genotype -> m Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return Genotype :: Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Genotype
Genotype{Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
torso :: Float
ar :: Float
eyef :: Float
eyea :: Float
nosel :: Float
noses :: Float
noseh :: Float
pupill :: Float
pupils :: Float
pupilh :: Float
eyel :: Float
eyes :: Float
eyeh :: Float
skinh :: Float
torso :: Float
eary :: Float
earx :: Float
nosey :: Float
nosex :: Float
eyey :: Float
eyex :: Float
heady :: Float
headx :: Float
ar :: Float
..}


-- | Perform crossover between genotypes.
crossover :: MonadFail m
          => StatefulGen g m
          => g          -- ^ The random-number generator.
          -> [Genotype] -- ^ The genotypes to be crossed.
          -> m Genotype -- ^ The action to cross the genotypes.
crossover :: g -> [Genotype] -> m Genotype
crossover g
g [Genotype]
genotypes =
  do
    let
      blend :: a -> a -> a -> a
blend a
f a
h0 a
h1 =
        let
          delta :: a
delta = a
h1 a -> a -> a
forall a. Num a => a -> a -> a
- a
h0
          delta' :: a
delta' =
            if a -> a
forall a. Num a => a -> a
abs a
delta a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
180
              then a
delta
              else a
delta a -> a -> a
forall a. Num a => a -> a -> a
- a
360
        in
          (a
h0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
f a -> a -> a
forall a. Num a => a -> a -> a
* a
delta') a -> a -> a
forall a. Real a => a -> a -> a
`mod'` a
360
      n :: Int
n = [Genotype] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Genotype]
genotypes
    [Int
ar', Int
headx', Int
heady', Int
eyex', Int
eyey', Int
nosex', Int
nosey', Int
earx', Int
eary', Int
torso', Int
eyeh', Int
eyes', Int
eyel', Int
pupilh', Int
pupils', Int
pupill', Int
noseh', Int
noses', Int
nosel', Int
eyea', Int
eyef'] <- Int -> m Int -> m [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
21 (m Int -> m [Int]) -> m Int -> m [Int]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> g -> m Int
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) g
g
    [Float
skinh'] <- Int -> m Float -> m [Float]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
1 (m Float -> m [Float]) -> m Float -> m [Float]
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> g -> m Float
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Float
0, Float
1) g
g
    Genotype -> m Genotype
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Genotype -> m Genotype) -> Genotype -> m Genotype
forall a b. (a -> b) -> a -> b
$ Genotype :: Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Genotype
Genotype
      {
        ar :: Float
ar      = Genotype -> Float
ar     (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
ar'    
      , headx :: Float
headx   = Genotype -> Float
headx  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
headx' 
      , heady :: Float
heady   = Genotype -> Float
heady  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
heady' 
      , eyex :: Float
eyex    = Genotype -> Float
eyex   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyex'  
      , eyey :: Float
eyey    = Genotype -> Float
eyey   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyey'  
      , nosex :: Float
nosex   = Genotype -> Float
nosex  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
nosex' 
      , nosey :: Float
nosey   = Genotype -> Float
nosey  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
nosey' 
      , earx :: Float
earx    = Genotype -> Float
earx   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
earx'  
      , eary :: Float
eary    = Genotype -> Float
eary   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eary'  
      , torso :: Float
torso   = Genotype -> Float
torso  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
torso' 
      , skinh :: Float
skinh   = (Float -> Float -> Float) -> [Float] -> Float
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Float -> Float -> Float -> Float
forall a. Real a => a -> a -> a -> a
blend Float
skinh') ([Float] -> Float) -> [Float] -> Float
forall a b. (a -> b) -> a -> b
$ Genotype -> Float
skinh (Genotype -> Float) -> [Genotype] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Genotype]
genotypes
      , eyeh :: Float
eyeh    = Genotype -> Float
eyeh   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyeh'  
      , eyes :: Float
eyes    = Genotype -> Float
eyes   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyes'  
      , eyel :: Float
eyel    = Genotype -> Float
eyel   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyel'  
      , pupilh :: Float
pupilh  = Genotype -> Float
pupilh (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
pupilh'
      , pupils :: Float
pupils  = Genotype -> Float
pupils (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
pupils'
      , pupill :: Float
pupill  = Genotype -> Float
pupill (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
pupill'
      , noseh :: Float
noseh   = Genotype -> Float
noseh  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
noseh' 
      , noses :: Float
noses   = Genotype -> Float
noses  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
noses' 
      , nosel :: Float
nosel   = Genotype -> Float
nosel  (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
nosel' 
      , eyea :: Float
eyea    = Genotype -> Float
eyea   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyea'  
      , eyef :: Float
eyef    = Genotype -> Float
eyef   (Genotype -> Float) -> Genotype -> Float
forall a b. (a -> b) -> a -> b
$ [Genotype]
genotypes [Genotype] -> Int -> Genotype
forall a. [a] -> Int -> a
!! Int
eyef'  
      }