parentaltesting.hs

import Data.List

data BloodType = BloodA | BloodB | BloodAB | BloodO deriving (Eq, Show)
data Gene = A | B | O deriving (Eq, Show, Ord)
type Genes = [Gene]

allGenes = [A, B, O]

possibleGenesByBlood :: BloodType -> [Genes]
possibleGenesByBlood BloodA = [[A, O], [A, A]]
possibleGenesByBlood BloodB = [[B, O], [B, B]]
possibleGenesByBlood BloodAB = [[A, B]]
possibleGenesByBlood BloodO = [[O, O]]

geneToBlood :: Genes -> BloodType
geneToBlood [A, O] = BloodA
geneToBlood [A, A] = BloodA
geneToBlood [B, O] = BloodB
geneToBlood [B, A] = BloodB
geneToBlood [A, B] = BloodAB
geneToBlood [O, O] = BloodO

possibleCombinations :: Gene -> [Genes]
possibleCombinations gene = do
    otherGene <- allGenes
    if gene < otherGene
        then return [gene, otherGene]
        else return [otherGene, gene]

possibleFatherGenes :: BloodType -> BloodType -> [Genes]
possibleFatherGenes childBlood motherBlood = 
    nub $ do
        childGenes <- possibleGenesByBlood childBlood
        motherGenes <- possibleGenesByBlood motherBlood
        fatherGene <- childGenes \\ motherGenes
        possibleCombinations fatherGene

isFather :: BloodType -> BloodType -> BloodType -> Bool
isFather childBlood motherBlood fatherBlood =
    any ((fatherBlood==) . geneToBlood) $ possibleFatherGenes childBlood motherBlood

parentaltesting2.hs

import Control.Monad

data BloodType = A | B | AB | O deriving (Eq, Show, Read)
data Allele = AlleleA | AlleleB | AlleleO deriving Eq
type Gene = (Allele, Allele)

possibleGenes :: BloodType -> [Gene]
possibleGenes A = [(AlleleA, AlleleA), (AlleleA, AlleleO)]
possibleGenes B = [(AlleleB, AlleleB), (AlleleB, AlleleO)]
possibleGenes AB = [(AlleleA, AlleleB)]
possibleGenes O = [(AlleleO, AlleleO)]

has :: Gene -> Allele -> Bool
has (x,y) z = z `elem` [x, y]

matchGenes :: Gene -> Gene -> Gene -> Bool
matchGenes (x,y) mother father =
    (mother `has` x && father `has` y) || (mother `has` y && father `has` x)

isValidParents :: BloodType -> BloodType -> BloodType -> Bool
isValidParents child mother father =
    or $ do
        childGenes <- possibleGenes child
        motherGenes <- possibleGenes mother
        fatherGenes <- possibleGenes father
        return $ matchGenes childGenes motherGenes fatherGenes

main = do
    putStrLn "What's your blood type?"
    child <- liftM read getLine
    putStrLn "What's your mother blood type?"
    mother <- liftM read getLine
    putStrLn "What's your father blood type?"
    father <- liftM read getLine
    if isValidParents child mother father
        then putStrLn ":-)"
        else putStrLn ":-("

I think the second one is a little better, I'm not sure. At least it's doesn't have unmatched patterns.