AvoidF, without transderivationality, using Functors

AvoidF.hs

-- details here http://tiny.cc/avoidf

{-# LANGUAGE FlexibleInstances #-}

module Main (main) where

type E = String
type T = String
data F a = F a [a] deriving (Show, Eq)

domain :: [E]
domain = ["Bill", "Mary", "Sue", "John"]

instance Functor F where
  fmap k (F x xs) = F (k x) $ map k xs

pamf :: F a -> (a -> b) -> F b
pamf = flip fmap

foc :: E -> F E
foc x = F x domain

saw :: (E, E) -> T
saw (x, y) = x ++ " saw " ++ y

class Contrast f where
  contrast :: T -> f -> Bool
  point :: f -> T

instance Contrast (F T) where
  contrast c (F x xs) = any (\y -> y == c && y /= x) xs
  point (F x xs) = x

instance {-# OVERLAPS #-} (Eq a, Contrast a) => Contrast (F a) where
  contrast c (F x xs) = any (\y -> contrast c y && y /= x) xs
  point (F x xs) = point x

ant = saw ("John", "Mary")  -- John saw Mary

s0 = foc "Bill" `pamf`
  \x -> saw (x, "Mary")     -- BILL saw Mary
s1 = foc "Mary" `pamf`
  \x -> saw ("Bill", x)     -- Bill saw MARY
s2 = foc "Bill" `pamf`
  \x -> foc "Mary" `pamf`
    \y -> saw (x, y)        -- BILL saw MARY (SS)
s3 = foc "Mary" `pamf`
  \y -> foc "Bill" `pamf`
    \x -> saw (x, y)        -- BILL saw MARY (IS)
s4 = foc "Bill" `pamf`
  \x -> foc "Bill" `pamf`
    \y -> saw (x, y)        -- BILL saw BILL (SS)
s5 = foc "Bill" `pamf`
  \y -> foc "Bill" `pamf`
    \x -> saw (x, y)        -- BILL saw BILL (IS)
s6 = foc "Bill" `pamf`
  \x -> foc "Sue" `pamf`
    \y -> saw (x, y)        -- BILL saw SUE (SS)
s7 = foc "Sue" `pamf`
  \y -> foc "Bill" `pamf`
    \x -> saw (x, y)        -- BILL saw SUE (SS)

(<~>) :: (Contrast f) => T -> f -> T
c <~> f = if contrast c f then point f else "that doesn't contrast"

-- some test cases
test :: [String]
test =
  [ ant <~> s0
  , ant <~> s1
  , ant <~> s2
  , ant <~> s3
  , ant <~> s4
  , ant <~> s5
  , ant <~> s6
  , ant <~> s7 ]

main :: IO ()
main = putStr . unlines $ test