equivalences.hs

import Data.Map (Map)
import qualified Data.Map as M

partitionM :: Applicative f => (a -> f Bool) -> [a] -> f ([a], [a])
partitionM f xs = mconcat <$> traverse inject xs where
	inject x = (\b -> ([x | b], [x | not b])) <$> f x

partitions :: Ord a => [a] -> [Map a Integer]
partitions = go 0 where
	go _ [] = [M.empty]
	go n (x:xs) = do
		(eq, notEq) <- partitionM (const [False, True]) xs
		rest <- go (n+1) notEq
		pure $ M.union (M.fromList [(x', n) | x' <- x:eq]) rest

-- and so universe = [Equivalence (\x y -> M.lookup x m == M.lookup y m) | m <- partitions universeF]