{-# language TypeFamilies #-}
module Ersatz.Relation.Data (
Relation
, relation, symmetric_relation
, build
, buildFrom, buildFromM
, identity
, bounds, (!), indices, assocs, elems
, domain, codomain, universe
, universeSize
, is_homogeneous
, card
, table
) where
import Prelude hiding ( and, (&&), any )
import Ersatz.Bit
import Ersatz.Bits ( Bits, sumBit )
import Ersatz.Codec
import Ersatz.Variable (exists)
import Ersatz.Problem (MonadSAT)
import Control.Monad (guard)
import qualified Data.Array as A
import Data.Array ( Array, Ix )
newtype Relation a b = Relation (Array (a, b) Bit)
instance (Ix a, Ix b) => Codec (Relation a b) where
type Decoded (Relation a b) = Array (a, b) Bool
decode :: Solution -> Relation a b -> Maybe (Decoded (Relation a b))
decode Solution
s (Relation Array (a, b) Bit
a) = Solution -> Array (a, b) Bit -> Maybe (Decoded (Array (a, b) Bit))
forall a. Codec a => Solution -> a -> Maybe (Decoded a)
decode Solution
s Array (a, b) Bit
a
encode :: Decoded (Relation a b) -> Relation a b
encode Decoded (Relation a b)
a = Array (a, b) Bit -> Relation a b
forall a b. Array (a, b) Bit -> Relation a b
Relation (Array (a, b) Bit -> Relation a b)
-> Array (a, b) Bit -> Relation a b
forall a b. (a -> b) -> a -> b
$ Decoded (Array (a, b) Bit) -> Array (a, b) Bit
forall a. Codec a => Decoded a -> a
encode Decoded (Array (a, b) Bit)
Decoded (Relation a b)
a
relation :: ( Ix a, Ix b, MonadSAT s m ) =>
((a,b),(a,b))
-> m ( Relation a b )
relation :: forall a b s (m :: * -> *).
(Ix a, Ix b, MonadSAT s m) =>
((a, b), (a, b)) -> m (Relation a b)
relation ((a, b), (a, b))
bnd = do
[((a, b), Bit)]
pairs <- [m ((a, b), Bit)] -> m [((a, b), Bit)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m ((a, b), Bit)] -> m [((a, b), Bit)])
-> [m ((a, b), Bit)] -> m [((a, b), Bit)]
forall a b. (a -> b) -> a -> b
$ do
(a, b)
p <- ((a, b), (a, b)) -> [(a, b)]
forall a. Ix a => (a, a) -> [a]
A.range ((a, b), (a, b))
bnd
m ((a, b), Bit) -> [m ((a, b), Bit)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (m ((a, b), Bit) -> [m ((a, b), Bit)])
-> m ((a, b), Bit) -> [m ((a, b), Bit)]
forall a b. (a -> b) -> a -> b
$ do
Bit
x <- m Bit
forall a s (m :: * -> *). (Variable a, MonadSAT s m) => m a
exists
((a, b), Bit) -> m ((a, b), Bit)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ( (a, b)
p, Bit
x )
Relation a b -> m (Relation a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Relation a b -> m (Relation a b))
-> Relation a b -> m (Relation a b)
forall a b. (a -> b) -> a -> b
$ ((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
build ((a, b), (a, b))
bnd [((a, b), Bit)]
pairs
symmetric_relation ::
(MonadSAT s m, Ix b) =>
((b, b), (b, b))
-> m (Relation b b)
symmetric_relation :: forall s (m :: * -> *) b.
(MonadSAT s m, Ix b) =>
((b, b), (b, b)) -> m (Relation b b)
symmetric_relation ((b, b), (b, b))
bnd = do
[[((b, b), Bit)]]
pairs <- [m [((b, b), Bit)]] -> m [[((b, b), Bit)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m [((b, b), Bit)]] -> m [[((b, b), Bit)]])
-> [m [((b, b), Bit)]] -> m [[((b, b), Bit)]]
forall a b. (a -> b) -> a -> b
$ do
(b
p,b
q) <- ((b, b), (b, b)) -> [(b, b)]
forall a. Ix a => (a, a) -> [a]
A.range ((b, b), (b, b))
bnd
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ b
p b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
q
m [((b, b), Bit)] -> [m [((b, b), Bit)]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (m [((b, b), Bit)] -> [m [((b, b), Bit)]])
-> m [((b, b), Bit)] -> [m [((b, b), Bit)]]
forall a b. (a -> b) -> a -> b
$ do
Bit
x <- m Bit
forall a s (m :: * -> *). (Variable a, MonadSAT s m) => m a
exists
[((b, b), Bit)] -> m [((b, b), Bit)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([((b, b), Bit)] -> m [((b, b), Bit)])
-> [((b, b), Bit)] -> m [((b, b), Bit)]
forall a b. (a -> b) -> a -> b
$ ((b
p,b
q), Bit
x)
((b, b), Bit) -> [((b, b), Bit)] -> [((b, b), Bit)]
forall a. a -> [a] -> [a]
: [ ((b
q,b
p), Bit
x) | b
p b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
q ]
Relation b b -> m (Relation b b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Relation b b -> m (Relation b b))
-> Relation b b -> m (Relation b b)
forall a b. (a -> b) -> a -> b
$ ((b, b), (b, b)) -> [((b, b), Bit)] -> Relation b b
forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
build ((b, b), (b, b))
bnd ([((b, b), Bit)] -> Relation b b)
-> [((b, b), Bit)] -> Relation b b
forall a b. (a -> b) -> a -> b
$ [[((b, b), Bit)]] -> [((b, b), Bit)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[((b, b), Bit)]]
pairs
build :: ( Ix a, Ix b )
=> ((a,b),(a,b))
-> [ ((a,b), Bit ) ]
-> Relation a b
build :: forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
build ((a, b), (a, b))
bnd [((a, b), Bit)]
pairs = Array (a, b) Bit -> Relation a b
forall a b. Array (a, b) Bit -> Relation a b
Relation (Array (a, b) Bit -> Relation a b)
-> Array (a, b) Bit -> Relation a b
forall a b. (a -> b) -> a -> b
$ ((a, b), (a, b)) -> [((a, b), Bit)] -> Array (a, b) Bit
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array ((a, b), (a, b))
bnd [((a, b), Bit)]
pairs
buildFrom :: (Ix a, Ix b)
=> ((a,b),(a,b))
-> ((a,b) -> Bit)
-> Relation a b
buildFrom :: forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> ((a, b) -> Bit) -> Relation a b
buildFrom ((a, b), (a, b))
bnd (a, b) -> Bit
p = ((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
build ((a, b), (a, b))
bnd ([((a, b), Bit)] -> Relation a b)
-> [((a, b), Bit)] -> Relation a b
forall a b. (a -> b) -> a -> b
$ (((a, b) -> ((a, b), Bit)) -> [(a, b)] -> [((a, b), Bit)])
-> [(a, b)] -> ((a, b) -> ((a, b), Bit)) -> [((a, b), Bit)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a, b) -> ((a, b), Bit)) -> [(a, b)] -> [((a, b), Bit)]
forall a b. (a -> b) -> [a] -> [b]
map (((a, b), (a, b)) -> [(a, b)]
forall a. Ix a => (a, a) -> [a]
A.range ((a, b), (a, b))
bnd) (((a, b) -> ((a, b), Bit)) -> [((a, b), Bit)])
-> ((a, b) -> ((a, b), Bit)) -> [((a, b), Bit)]
forall a b. (a -> b) -> a -> b
$ \ (a, b)
i -> ((a, b)
i, (a, b) -> Bit
p (a, b)
i)
buildFromM :: (Ix a, Ix b, MonadSAT s m)
=> ((a,b),(a,b))
-> ((a,b) -> m Bit)
-> m (Relation a b)
buildFromM :: forall a b s (m :: * -> *).
(Ix a, Ix b, MonadSAT s m) =>
((a, b), (a, b)) -> ((a, b) -> m Bit) -> m (Relation a b)
buildFromM ((a, b), (a, b))
bnd (a, b) -> m Bit
p = do
[((a, b), Bit)]
pairs <- [m ((a, b), Bit)] -> m [((a, b), Bit)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m ((a, b), Bit)] -> m [((a, b), Bit)])
-> [m ((a, b), Bit)] -> m [((a, b), Bit)]
forall a b. (a -> b) -> a -> b
$ do
(a, b)
i <- ((a, b), (a, b)) -> [(a, b)]
forall a. Ix a => (a, a) -> [a]
A.range ((a, b), (a, b))
bnd
m ((a, b), Bit) -> [m ((a, b), Bit)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (m ((a, b), Bit) -> [m ((a, b), Bit)])
-> m ((a, b), Bit) -> [m ((a, b), Bit)]
forall a b. (a -> b) -> a -> b
$ do
Bit
x <- (a, b) -> m Bit
p (a, b)
i
((a, b), Bit) -> m ((a, b), Bit)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, b)
i, Bit
x)
Relation a b -> m (Relation a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Relation a b -> m (Relation a b))
-> Relation a b -> m (Relation a b)
forall a b. (a -> b) -> a -> b
$ ((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> [((a, b), Bit)] -> Relation a b
build ((a, b), (a, b))
bnd [((a, b), Bit)]
pairs
identity :: (Ix a)
=> ((a,a),(a,a))
-> Relation a a
identity :: forall a. Ix a => ((a, a), (a, a)) -> Relation a a
identity ((a
a,a
b),(a
c,a
d))
| (a
a,a
c) (a, a) -> (a, a) -> Bool
forall a. Eq a => a -> a -> Bool
== (a
b,a
d) = ((a, a), (a, a)) -> ((a, a) -> Bit) -> Relation a a
forall a b.
(Ix a, Ix b) =>
((a, b), (a, b)) -> ((a, b) -> Bit) -> Relation a b
buildFrom ((a
a,a
b),(a
c,a
d)) (\ (a
i,a
j) -> Bool -> Bit
forall b. Boolean b => Bool -> b
bool (Bool -> Bit) -> Bool -> Bit
forall a b. (a -> b) -> a -> b
$ a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
j)
| Bool
otherwise = [Char] -> Relation a a
forall a. HasCallStack => [Char] -> a
error [Char]
"The domain must equal the codomain!"
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) Bit
r ) = Array (a, b) Bit -> ((a, b), (a, b))
forall i e. Array i e -> (i, i)
A.bounds Array (a, b) Bit
r
indices :: (Ix a, Ix b) => Relation a b -> [(a, b)]
indices :: forall a b. (Ix a, Ix b) => Relation a b -> [(a, b)]
indices ( Relation Array (a, b) Bit
r ) = Array (a, b) Bit -> [(a, b)]
forall i e. Ix i => Array i e -> [i]
A.indices Array (a, b) Bit
r
assocs :: (Ix a, Ix b) => Relation a b -> [((a, b), Bit)]
assocs :: forall a b. (Ix a, Ix b) => Relation a b -> [((a, b), Bit)]
assocs ( Relation Array (a, b) Bit
r ) = Array (a, b) Bit -> [((a, b), Bit)]
forall i e. Ix i => Array i e -> [(i, e)]
A.assocs Array (a, b) Bit
r
elems :: (Ix a, Ix b) => Relation a b -> [Bit]
elems :: forall a b. (Ix a, Ix b) => Relation a b -> [Bit]
elems ( Relation Array (a, b) Bit
r ) = Array (a, b) Bit -> [Bit]
forall i e. Array i e -> [e]
A.elems Array (a, b) Bit
r
(!) :: (Ix a, Ix b) => Relation a b -> (a, b) -> Bit
Relation Array (a, b) Bit
r ! :: forall a b. (Ix a, Ix b) => Relation a b -> (a, b) -> Bit
! (a, b)
p = Array (a, b) Bit
r Array (a, b) Bit -> (a, b) -> Bit
forall i e. Ix i => Array i e -> i -> e
A.! (a, b)
p
domain :: (Ix a, Ix b) => Relation a b -> [a]
domain :: forall a b. (Ix a, Ix b) => Relation a b -> [a]
domain Relation a b
r =
let ((a
x,b
_),(a
x',b
_)) = Relation a b -> ((a, b), (a, b))
forall a b. (Ix a, Ix b) => Relation a b -> ((a, b), (a, b))
bounds Relation a b
r
in (a, a) -> [a]
forall a. Ix a => (a, a) -> [a]
A.range (a
x,a
x')
codomain :: (Ix a, Ix b) => Relation a b -> [b]
codomain :: forall a b. (Ix a, Ix b) => Relation a b -> [b]
codomain Relation a b
r =
let ((a
_,b
y),(a
_,b
y')) = Relation a b -> ((a, b), (a, b))
forall a b. (Ix a, Ix b) => Relation a b -> ((a, b), (a, b))
bounds Relation a b
r
in (b, b) -> [b]
forall a. Ix a => (a, a) -> [a]
A.range (b
y,b
y')
universe :: Ix a => Relation a a -> [a]
universe :: forall a. Ix a => Relation a a -> [a]
universe Relation a a
r
| Relation a a -> Bool
forall a. Ix a => Relation a a -> Bool
is_homogeneous Relation a a
r = Relation a a -> [a]
forall a b. (Ix a, Ix b) => Relation a b -> [a]
domain Relation a a
r
| Bool
otherwise = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"Relation is not homogeneous!"
universeSize :: Ix a => Relation a a -> Int
universeSize :: forall a. Ix a => Relation a a -> Int
universeSize Relation a a
r
| Relation a a -> Bool
forall a. Ix a => Relation a a -> Bool
is_homogeneous Relation a a
r =
let ((a
a,a
_),(a
c,a
_)) = Relation a a -> ((a, a), (a, a))
forall a b. (Ix a, Ix b) => Relation a b -> ((a, b), (a, b))
bounds Relation a a
r
in (a, a) -> Int
forall a. Ix a => (a, a) -> Int
A.rangeSize (a
a,a
c)
| Bool
otherwise = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Relation is not homogeneous!"
is_homogeneous :: Ix a => Relation a a -> Bool
is_homogeneous :: forall a. Ix a => Relation a a -> Bool
is_homogeneous Relation a a
r =
let ((a
a,a
b),(a
c,a
d)) = Relation a a -> ((a, a), (a, a))
forall a b. (Ix a, Ix b) => Relation a b -> ((a, b), (a, b))
bounds Relation a a
r
in (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b) Bool -> Bool -> Bool
forall b. Boolean b => b -> b -> b
&& (a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
d)
card :: (Ix a, Ix b) => Relation a b -> Bits
card :: forall a b. (Ix a, Ix b) => Relation a b -> Bits
card = [Bit] -> Bits
forall (t :: * -> *). Foldable t => t Bit -> Bits
sumBit ([Bit] -> Bits) -> (Relation a b -> [Bit]) -> Relation a b -> Bits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation a b -> [Bit]
forall a b. (Ix a, Ix b) => Relation a b -> [Bit]
elems
table :: (Ix a, Ix b)
=> Array (a,b) Bool -> String
table :: forall a b. (Ix a, Ix b) => Array (a, b) Bool -> [Char]
table Array (a, b) Bool
r = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ do
let ((a
a,b
b),(a
c,b
d)) = Array (a, b) Bool -> ((a, b), (a, b))
forall i e. Array i e -> (i, i)
A.bounds Array (a, b) Bool
r
a
x <- (a, a) -> [a]
forall a. Ix a => (a, a) -> [a]
A.range (a
a,a
c)
[Char] -> [[Char]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ do
b
y <- (b, b) -> [b]
forall a. Ix a => (a, a) -> [a]
A.range (b
b,b
d)
[Char] -> [[Char]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ if Array (a, b) Bool
r Array (a, b) Bool -> (a, b) -> Bool
forall i e. Ix i => Array i e -> i -> e
A.! (a
x,b
y) then [Char]
"*" else [Char]
"."