Sepiidapus breeding tools

SepiidapusBreeding.hs

{-# LANGUAGE TemplateHaskell #-}
module SepiidapusBreeding where 

import Data.List

import Data.Lens.Common
import Data.Lens.Template

data Karyo
    = I
    | X
    | Y
    | Z
  deriving (Show, Read, Eq, Ord, Enum)

aMale a = 
    [ [I, I, a]
    , [I, X, a]
    , [X, X, a]
    ]

female = [[I, X, X], [X, X, X]]

male = aMale Y

detmale = aMale Z

shell = [[I, I, I], [I, I, X]]

brain = [[I, Y, Z], [X, Y, Z]]

takeTwo k = [ [snd k1, snd k2] | 
             k1 <- ks,
             k2 <- ks,
             fst k1 /= fst k2 ]
  where ks = zip [1..] k

cross2 fK mK = [ sort $ m : fs | m <- mK, fs <- takeTwo fK ]

cross3 fK mK dK = [ sort [f, m, d] | f <- fK, m <- mK, d <- dK ]

data SexCount = SexCount
    { _scFemale :: Int
    , _scMale :: Int
    , _scDet :: Int
    , _scShell :: Int
    , _scBrain :: Int
    , _scTotal :: Int
    }
  deriving (Show)

makeLens ''SexCount

putSexCount sc = do 
    let iTot = getL scTotal sc
    putCount "Female" iTot $ getL scFemale sc
    putCount "Male" iTot $ getL scMale sc
    putCount "Detmale" iTot $ getL scDet sc
    putCount "Shell" iTot $ getL scShell sc
    putCount "Brain" iTot $ getL scBrain sc
    putStr "Total: " >> print iTot
  where putCount lbl iTot cnt = do
            putStr lbl >> putStr ": "
            putStr $ show cnt
            putStr " ("
            putStr $ show $ 100 * fromIntegral cnt / fromIntegral iTot
            putStrLn "%)"

combineSexCounts sc1 sc2 = SexCount
    (_scFemale sc1 + _scFemale sc2)
    (_scMale sc1 + _scMale sc2)
    (_scDet sc1 + _scDet sc2)
    (_scShell sc1 + _scShell sc2)
    (_scBrain sc1 + _scBrain sc2)
    (_scTotal sc1 + _scTotal sc2)

scaleSexCount k sc1 = SexCount
    (_scFemale sc1 * k)
    (_scMale sc1 * k)
    (_scDet sc1 * k)
    (_scShell sc1 * k)
    (_scBrain sc1 * k)
    (_scTotal sc1 * k)

mkSexCount = SexCount 0 0 0 0 0 0

sexCount = foldl' tally mkSexCount
  where tally = modL scTotal (1+) .: tally'
        tally' sc k
            | k `elem` female = modL scFemale (1+) sc
            | k `elem` male = modL scMale (1+) sc
            | k `elem` detmale = modL scDet (1+) sc
            | k `elem` shell = modL scShell (1+) sc
            | k `elem` brain = modL scBrain (1+) sc
            | otherwise = error $ show k

someRatio = foldl' combineSexCounts mkSexCount
    [ scaleSexCount 9 $ sexCount $ concat 
        [ cross2 f m | f <- female, m <- male ++ detmale ]
    , scaleSexCount 1 $ sexCount $ concat
        [ cross3 f m d | f <- female, m <- male, d <- detmale ]
    ]

(.:) = (.).(.)