avoidf.hs

{-# LANGUAGE FlexibleInstances #-}

module Main (main) where

main :: IO ()
main = return ()

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 Alts f where
  alts :: f -> [T]

instance Alts (F T) where
  alts (F x xs) = x : xs

instance {-# OVERLAPS #-} Alts a => Alts (F a) where
  alts (F x xs) = alts x ++ concatMap alts xs

class Point f where
  point :: f -> T

instance Point (F T) where
  point (F x xs) = x

instance {-# OVERLAPS #-} Point a => Point (F a) where
  point (F x xs) = point x

contrast :: (Point f, Alts f) => T -> f -> Bool
contrast c f = point f /= c && length [x | x <- alts f, x == c] == 1

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)

(<~>) :: (Point f, Alts f) => T -> f -> T
c <~> f = if contrast c f then point f else "you failed to contrast"

-- some test cases
-- ant <~> s0
-- ant <~> s1
-- ant <~> s2
-- ant <~> s3
-- ant <~> s4
-- ant <~> s5
-- ant <~> s6
-- ant <~> s7

{-# LANGUAGE FlexibleInstances #-}

module Main (main) where

main :: IO ()
main = return ()

type E = String
data T = T {unT :: String} deriving (Show, Eq)
data F a = Pair (a, [a]) deriving (Show, Eq)

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

pamf :: F a -> (a -> b) -> F b
pamf (Pair (x, a)) f = Pair (f x, map f a)

instance Functor F where
  fmap = flip pamf

alt :: E -> [E]
alt x = domain

foc :: E -> F E
foc x = Pair (x, alt x)

left :: E -> T
left x = T $ x ++ " left"

likes :: E -> E -> T
likes y x = T $ x ++ " likes " ++ y

ant = likes "Mary" "John"
s0 = foc "Bob" `pamf` \x -> likes "Mary" x
s1 = foc "Mary" `pamf` \x -> likes x "Bob"
s2 = foc "Bob" `pamf` \x -> foc "Mary" `pamf` \y -> likes y x
s3 = foc "Bob" `pamf` \x -> foc "Sue" `pamf` \y -> likes y x

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

instance {-# OVERLAPS #-} Contrast (F T) where
  contrast x (Pair (y, ys)) = not $ x == y || x `notElem` ys

instance {-# OVERLAPS #-} Contrast a => Contrast (F a) where
  contrast x (Pair (y, ys)) = contrast x y || or (map (contrast x) ys)