{-# language FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} module Satchmo.Relation.Data ( Relation , relation, symmetric_relation , build , identity , bounds, (!), indices, assocs, elems , table ) where import Satchmo.Code import Satchmo.Boolean import Satchmo.SAT import qualified Data.Array as A import Data.Array ( Array, Ix ) import Data.Functor ((<$>)) import Control.Monad ( guard, forM ) newtype Relation a b = Relation ( Array (a,b) Boolean ) relation :: ( Ix a, Ix b, MonadSAT m ) => ((a,b),(a,b)) -> m ( Relation a b ) {-# specialize inline relation :: ( Ix a, Ix b) => ((a,b),(a,b)) -> SAT ( Relation a b ) #-} relation :: forall a b (m :: * -> *). (Ix a, Ix b, MonadSAT m) => ((a, b), (a, b)) -> m (Relation a b) relation ((a, b), (a, b)) bnd = do [((a, b), Boolean)] pairs <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ do (a, b) p <- forall a. Ix a => (a, a) -> [a] A.range ((a, b), (a, b)) bnd forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ do Boolean x <- forall (m :: * -> *). MonadSAT m => m Boolean boolean forall (m :: * -> *) a. Monad m => a -> m a return ( (a, b) p, Boolean x ) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (Ix a, Ix b) => ((a, b), (a, b)) -> [((a, b), Boolean)] -> Relation a b build ((a, b), (a, b)) bnd [((a, b), Boolean)] pairs symmetric_relation :: ((b, b), (b, b)) -> m (Relation b b) symmetric_relation ((b, b), (b, b)) bnd = do [[((b, b), Boolean)]] pairs <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ do (b p,b q) <- forall a. Ix a => (a, a) -> [a] A.range ((b, b), (b, b)) bnd forall (f :: * -> *). Alternative f => Bool -> f () guard forall a b. (a -> b) -> a -> b $ b p forall a. Ord a => a -> a -> Bool <= b q forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ do Boolean x <- forall (m :: * -> *). MonadSAT m => m Boolean boolean forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [ ((b p,b q), Boolean x ) ] forall a. [a] -> [a] -> [a] ++ [ ((b q,b p), Boolean x) | b p forall a. Eq a => a -> a -> Bool /= b q ] forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (Ix a, Ix b) => ((a, b), (a, b)) -> [((a, b), Boolean)] -> Relation a b build ((b, b), (b, b)) bnd forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[((b, b), Boolean)]] pairs identity :: ( Ix a, MonadSAT m) => ((a,a),(a,a)) -> m ( Relation a a ) identity :: forall a (m :: * -> *). (Ix a, MonadSAT m) => ((a, a), (a, a)) -> m (Relation a a) identity ((a, a), (a, a)) bnd = do Boolean f <- forall (m :: * -> *). MonadSAT m => Bool -> m Boolean constant Bool False Boolean t <- forall (m :: * -> *). MonadSAT m => Bool -> m Boolean constant Bool True forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (Ix a, Ix b) => ((a, b), (a, b)) -> [((a, b), Boolean)] -> Relation a b build ((a, a), (a, a)) bnd forall a b. (a -> b) -> a -> b $ forall {a} {b}. [a] -> (a -> b) -> [b] for ( forall a. Ix a => (a, a) -> [a] A.range ((a, a), (a, a)) bnd ) forall a b. (a -> b) -> a -> b $ \ (a i,a j) -> ((a i,a j), if a i forall a. Eq a => a -> a -> Bool == a j then Boolean t else Boolean f ) for :: [a] -> (a -> b) -> [b] for = forall a b c. (a -> b -> c) -> b -> a -> c flip forall a b. (a -> b) -> [a] -> [b] map build :: ( Ix a, Ix b ) => ((a,b),(a,b)) -> [ ((a,b), Boolean ) ] -> Relation a b build :: forall a b. (Ix a, Ix b) => ((a, b), (a, b)) -> [((a, b), Boolean)] -> Relation a b build ((a, b), (a, b)) bnd [((a, b), Boolean)] pairs = forall a b. Array (a, b) Boolean -> Relation a b Relation forall a b. (a -> b) -> a -> b $ forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e A.array ((a, b), (a, b)) bnd [((a, b), Boolean)] pairs bounds :: (Ix a, Ix b) => Relation a b -> ((a,b),(a,b)) bounds :: forall a b. (Ix a, Ix b) => Relation a b -> ((a, b), (a, b)) bounds ( Relation Array (a, b) Boolean r ) = forall i e. Array i e -> (i, i) A.bounds Array (a, b) Boolean r indices :: Relation a b -> [(a, b)] indices ( Relation Array (a, b) Boolean r ) = forall i e. Ix i => Array i e -> [i] A.indices Array (a, b) Boolean r assocs :: Relation a b -> [((a, b), Boolean)] assocs ( Relation Array (a, b) Boolean r ) = forall i e. Ix i => Array i e -> [(i, e)] A.assocs Array (a, b) Boolean r elems :: Relation a b -> [Boolean] elems ( Relation Array (a, b) Boolean r ) = forall i e. Array i e -> [e] A.elems Array (a, b) Boolean r Relation Array (a, b) Boolean r ! :: Relation a b -> (a, b) -> Boolean ! (a, b) p = Array (a, b) Boolean r forall i e. Ix i => Array i e -> i -> e A.! (a, b) p instance (Ix a, Ix b, Decode m Boolean Bool) => Decode m ( Relation a b ) ( Array (a,b) Bool ) where decode :: Relation a b -> m (Array (a, b) Bool) decode ( Relation Array (a, b) Boolean r ) = do forall (m :: * -> *) c a. Decode m c a => c -> m a decode Array (a, b) Boolean r table :: (Enum a, Ix a, Enum b, Ix b) => Array (a,b) Bool -> String table :: forall a b. (Enum a, Ix a, Enum b, Ix b) => Array (a, b) Bool -> String table Array (a, b) Bool r = [String] -> String unlines forall a b. (a -> b) -> a -> b $ do let ((a a,b b),(a c,b d)) = forall i e. Array i e -> (i, i) A.bounds Array (a, b) Bool r a x <- [ a a .. a c ] forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [String] -> String unwords forall a b. (a -> b) -> a -> b $ do b y <- [ b b .. b d ] forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ if Array (a, b) Bool r forall i e. Ix i => Array i e -> i -> e A.! (a x,b y) then String "*" else String "."