Hoodlums logic puzzle homework / fixed-length backtrack

Main.hs

{-# LANGUAGE MultiParamTypeClasses  #-}
module Main where
import Prelude
import Control.Applicative
import Data.Maybe
import Control.Monad
import Control.Arrow

data Girl = Ellie | Emily | Jessica
    deriving (Show, Eq, Enum, Bounded)

data Animal = Elephant | Zebra | Giraffe
    deriving (Show, Eq, Enum, Bounded)

data Lolly  = Grunge | Plooper | Zinger
    deriving (Show, Eq, Enum, Bounded)

data Adult  =  Aunt | Grandma | Mum
    deriving (Show, Eq, Enum, Bounded)
    
data Row = Row 
      { girl    :: Maybe Girl
      , animal  :: Maybe Animal
      , lolly   :: Maybe Lolly
      , adult   :: Maybe Adult }
  deriving Show

data Choices = Choices 
      { girls   :: [Girl]  
      , animals :: [Animal]
      , lollies :: [Lolly]
      , adults  :: [Adult] }

allChoice = Choices enums enums enums enums
remains :: Choices -> Row -> Choices
remains original row =
    Choices 
      ((girls original) `except` (girl row))
      ((animals original) `except` (animal row))
      ((lollies original) `except` (lolly row))
      ((adults original) `except` (adult row))
  where
    except :: Eq a => [a] -> Maybe a -> [a]
    except xs (Just x) = filter (/= x) xs
    except xs Nothing = xs

class (Enum a, Bounded a, Eq a) => Atom r a where
  get :: r -> Maybe a

instance Atom Row Girl   where get = girl
instance Atom Row Animal where get = animal
instance Atom Row Lolly  where get = lolly
instance Atom Row Adult  where get = adult

main :: IO ()
main = print $ solve
-- main = print $ permits $ Row (Just Ellie) Nothing (Just Zinger) Nothing

enums :: (Enum a, Bounded a) => [a]
enums = [minBound .. maxBound]

(==>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
f ==> g = \x -> (not $ f x) || (g x)

have :: Atom r a => a -> r -> Bool
have value row = (get row) == (Just value)
  
mayHave :: Atom r a => a -> r -> Bool
mayHave value row = 
    case get row of
      Just x | x == value -> True
      Nothing -> True
      _ -> False
  
checkRules :: Row -> Bool
checkRules row = 
    all ($row) rules
  where 
    rules = [ (have Ellie) ==> (not . (have Zinger))
            , (have Giraffe) ==> (not . (have Plooper))
            , (have Aunt) ==> (not . (have Jessica)) 
            , (have Ellie) ==> (mayHave Grandma)
            , (have Mum) ==> (mayHave Elephant)
            , (have Grunge) ==> (mayHave Aunt) ]

solve :: [[Row]]
solve = do
    r1 <- solveOne allChoice
    let set1 = remains allChoice r1
    r2 <- solveOne set1
    let set2 = remains set1 r2
    r3 <- solveOne set2
    return [r1,r2,r3]
    
solveOne :: Choices -> [Row]
solveOne choices = do
    let g = head $ girls choices
    a <- animals choices
    guard $ checkRules $ Row (Just g) (Just a) Nothing Nothing
    l <- lollies choices
    guard $ checkRules $ Row (Just g) (Just a) (Just l) Nothing
    d <- adults choices
    let row = Row (Just g) (Just a) (Just l) (Just d)
    guard $ checkRules $ row
    return row