Skip to content

Instantly share code, notes, and snippets.

@bryant

bryant/mend.hs

Created November 5, 2013 15:24
Show Gist options
  • Save bryant/7320695 to your computer and use it in GitHub Desktop.
Save bryant/7320695 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
mend.hs
data Genotype = AA | Aa | Xaa deriving Show
--data Poss = Poss Double Double Double deriving Show
type Poss = (Double, Double, Double)
mate :: Genotype -> Genotype -> Poss
mate AA AA = (1, 0, 0)
mate AA Aa = (0.5, 0.5, 0)
mate AA Xaa = (0, 1, 0)
mate Aa Aa = (0.25, 0.5, 0.25)
mate Aa Xaa = (0, 0.5, 0.5)
mate Xaa Xaa = (0, 0, 1)
mate x y = mate y x
sumPoss :: Poss -> Poss -> Poss
sumPoss (a0, a1, a2) (b0, b1, b2) = (a0+b0, a1+b1, a2+b2)
t :: Double -> Poss -> Poss
t k (a0, a1, a2) = (a0*k, a1*k, a2*k)
matePoss :: Poss -> Poss -> Poss
matePoss (xAA, aA, aa) (xBB, bB, bb) =
((xAA*xBB) `t` (mate AA AA)) `sumPoss` ((xAA*bB) `t` (mate AA Aa)) `sumPoss` ((xAA*bb) `t` (mate AA Xaa)) `sumPoss`
((aA*xBB) `t` (mate Aa AA)) `sumPoss` ((aA*bB) `t` (mate Aa Aa)) `sumPoss` ((aA*bb) `t` (mate Aa Xaa)) `sumPoss`
((aa*xBB) `t` (mate Xaa AA)) `sumPoss` ((aa*bB) `t` (mate Xaa Aa)) `sumPoss` ((aa*bb) `t` (mate Xaa Xaa))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment