{-# 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
"."