Research R- and L-classes over boolean matrices

BooleanMatrix.hs

import Data.List (find, partition)
import Control.Monad (replicateM, join)
import Control.Arrow ((***))
import Data.Maybe (fromJust)

import BooleanMatrixCore

{-- Matrix researches  --}

pairsFromRclass :: (Int, Int) -> [(BooleanMatrix, BooleanMatrix)]
pairsFromRclass (i, j) = [ (x,y) | x <- allMatrixs (i,j), y <- allMatrixs (i,j), x <* y, fromRClass x y ]

primaryIdempotentsFromRclass :: (Int, Int) -> [(BooleanMatrix, BooleanMatrix)]
primaryIdempotentsFromRclass (i, j) = [ (x,y) | x <- allMatrixs (i,j), y <- allMatrixs (i,j)
                                              , x <* y
                                              , primaryIdempotent x
                                              , primaryIdempotent y
                                              , fromRClass x y ]

secondaryIdempotentsFromRclass :: (Int, Int) -> [(BooleanMatrix, BooleanMatrix)]
secondaryIdempotentsFromRclass (i, j) = [ (x,y) | x <- allMatrixs (i,j), y <- allMatrixs (i,j)
                                              , x <* y
                                              , secondaryIdempotent x
                                              , secondaryIdempotent y
                                              , fromRClass x y ]

splitOffFirstGroup :: (a -> a -> Bool) -> [a] -> ([a], [a])
splitOffFirstGroup equal xs@(x:_) = partition (equal x) xs
splitOffFirstGroup _     []       = ([], [])

equivalenceClasses :: (a -> a -> Bool) -> [a] -> [[a]]
equivalenceClasses _     [] = []
equivalenceClasses equal xs = let (fg,rst) = splitOffFirstGroup equal xs
                              in fg : equivalenceClasses equal rst

equivalenceRClasses, equivalenceLClasses, equivalenceDClasses :: (Int, Int) -> [[BooleanMatrix]]
equivalenceRClasses (i,j) = equivalenceClasses fromRClassM $ allMatrixs (i,j)
equivalenceLClasses (i,j) = equivalenceClasses fromLClassM $ allMatrixs (i,j)
equivalenceDClasses (i,j) = map (concatMap (\x -> fromJust $ find (elem x) (equivalenceLClasses (i,j)))) (equivalenceRClasses (i,j))

{-- Results --}

examples = do
    putStrLn $ "x = " ++ show (matrix2Int x)
    putStrLn $ "y = " ++ show (matrix2Int y)
    putStrLn $ "x `multC` y (disj of conjs) = " ++ show (matrix2Int $ multC x y)
    putStrLn $ "x `multD` y (conj of disjs) = " ++ show (matrix2Int $ multD x y)
    putStrLn $ "idempotent x = " ++ show (matrix2Int $ idempotent x)
    putStrLn $ "x and y from R-class? " ++ show (fromRClass x y)
    putStrLn $ "x and y from L-class? " ++ show (fromLClass x y)
    where x = int2Matrix (3,3) [1,0,1,1,0,0,0,0,1]
          y = int2Matrix (3,3) [0,0,1,1,0,1,0,0,0]

pairsFromRclassPrint :: (Int, Int) -> IO()
pairsFromRclassPrint (i, j) = do
    putStrLn $ show (i,j) ++ " matrices from one R-class: "
    mapM_ ( print . join (***) matrix2Int) $ pairsFromRclass (i,j)

primaryIdempotentsFromRclassPrint :: (Int, Int) -> IO()
primaryIdempotentsFromRclassPrint (i, j) = do
    putStrLn $ show (i,j) ++ " primary idempotents from one R-class: "
    mapM_ ( print . join (***) matrix2Int) $ primaryIdempotentsFromRclass (i,j)

secondaryIdempotentsFromRclassPrint :: (Int, Int) -> IO()
secondaryIdempotentsFromRclassPrint (i,j) = do
    putStrLn $ show (i,j) ++ " secondary idempotents from one R-class: "
    mapM_ ( print . join (***) matrix2Int) $ secondaryIdempotentsFromRclass (i,j)

equivalenceRClassesPrint, equivalenceLClassesPrint, equivalenceDClassesPrint :: (Int, Int) -> IO()
equivalenceRClassesPrint (i,j) = do
    putStrLn ( "R classes of " ++ show (i,j) ++ " matrices" )
    mapM_ (putStrLn . showMatrices) $ equivalenceRClasses (i, j)

equivalenceLClassesPrint (i,j) = do
    putStrLn ( "L classes of " ++ show (i,j) ++ " matrices" )
    mapM_ (putStrLn . showMatrices) $ equivalenceLClasses (i, j)

equivalenceDClassesPrint (i,j) = do
    putStrLn ( "D classes of " ++ show (i,j) ++ " matrices" )
    mapM_ (putStrLn . showMatrices) $ equivalenceDClasses (i, j)

main = do
    equivalenceDClassesPrint (3,5)

BooleanMatrixCore.hs

module BooleanMatrixCore where

import Data.List (transpose, sort, subsequences, intercalate, find)
import Data.List.Split (splitEvery)
import Control.Arrow ((&&&),(***))
import Control.Monad (join, liftM2, replicateM)
import Test.HUnit (assertEqual, runTestTT, Test (..))
import Data.Maybe (isJust)

type BooleanMatrix = ((Int, Int), [Int])

{--
 -- Pseudo-Boolean Statements
 --}

infix 5 /\
(/\) :: Int -> Int -> Int
x /\ y = if x * y > 0 then 1 else 0

infix 4 \/
(\/) :: Int -> Int -> Int
x \/ y = if x + y > 0 then 1 else 0

(~~) :: Int -> Int
(~~) 0 = 1
(~~) 1 = 0

{--
 -- Frequently happend errors 
 --}
indexError a = error $ a ++ ": matrix index exceed"
dimensionsError a = error $ a ++ ": matrix dimensions not agree"

{--
 -- BooleanMatrix Properties
 --}
empty :: BooleanMatrix -> Bool
empty ((xi,xj), []) | xi == 0 || xj == 0 = True
empty _ = False

int2Matrix :: (Int, Int) -> [Int] -> BooleanMatrix
int2Matrix (i,j) values | i*j == length values = ((i,j), values)
                        | otherwise = dimensionsError "int2Matrix"

matrix2Int :: BooleanMatrix -> [Int]
matrix2Int (_, x) = x

bounds_ :: BooleanMatrix -> (Int, Int)
bounds_ ((i,j), _) = (i,j)

infixl 5 <*
{-- lexicographical order over the BooleanMatrix --}
( <* ) :: BooleanMatrix -> BooleanMatrix -> Bool
x <* y = uncurry (<) . join (***) matrix2Int $ (x,y)

sortRows, sortColumns :: BooleanMatrix -> BooleanMatrix
sortRows = foldl1 addRows . (sort . rows)
sortColumns = foldl1 addColumns . (sort . columns)

infix 5 !*
{-- get element from BooleanMatrix (analog of !!) --}
( !* ) :: BooleanMatrix -> (Int,Int) -> Int
((x_i, y_i),x) !* (i,j) | (i > x_i) || (j > y_i) = indexError "!*"
                        | otherwise = x !! ((i-1)*y_i + (j-1))

{--
 -- BooleanMatrix nice printing
 --}
showMatrix :: BooleanMatrix -> String
showMatrix = concatMap show . matrix2Int

showMatrices :: [BooleanMatrix] -> String
showMatrices ms = "[" ++ intercalate ", " (map showMatrix ms) ++ "]"

{--
 -- Operations over BooleanMatrices
 --}
multiplicateM :: ([Int] -> Int) -> (Int -> Int -> Int) -> BooleanMatrix -> BooleanMatrix -> BooleanMatrix
multiplicateM f1 f2 m1@((xi,xj),x) m2@((yi,yj),y) = (newBounds, [ f1 [f2 (m1 !* (i,k)) (m2 !* (k,j)) | k <- [1..xj]] | i <- [1..xi], j <- [1..yj] ])
    where newBounds | xj == yi  = (xi,yj)
                    | otherwise = dimensionsError "multiplicateM"

multD, multC :: BooleanMatrix -> BooleanMatrix -> BooleanMatrix
multD = multiplicateM (foldr1 (/\)) (\/)
multC = multiplicateM (foldr1 (\/)) (/\)

transposeM :: BooleanMatrix -> BooleanMatrix
transposeM x = int2Matrix newBounds transposedList
    where newBounds = (j,i)
          (i,j) = bounds_ x
          transposedList = concat $ transpose $ splitEvery i $ matrix2Int x

inverseM :: BooleanMatrix -> BooleanMatrix
inverseM x = int2Matrix (bounds_ x) inversedList
    where inversedList = map (~~) $ matrix2Int x

idempotent :: BooleanMatrix -> BooleanMatrix
idempotent = uncurry multD . (id &&& transposeM . inverseM)

disj, conj :: BooleanMatrix -> BooleanMatrix -> BooleanMatrix
disj m1@((xi,xj),x) m2@((yi,yj),y) | (xi,xj) == (yi,yj) = ((xi,xj), zipWith (\/) x y)
                                   | otherwise = dimensionsError "disj"
conj m1@((xi,xj),x) m2@((yi,yj),y) | (xi,xj) == (yi,yj) = ((xi,xj), zipWith (/\) x y)
                                   | otherwise = dimensionsError "conj"

{-- returns a disj/conj of all matrix's rows/columns --}
disjRows, disjColumns, conjRows, conjColumns :: BooleanMatrix -> BooleanMatrix
disjRows = foldl1 disj . rows
disjColumns = foldl1 disj . columns
conjRows = foldl1 conj . rows
conjColumns = foldl1 conj . columns

{-- handleME (ME stands for "MatrixElements") is just helps to avoid 4times using same code --}
handleME :: (BooleanMatrix -> BooleanMatrix -> BooleanMatrix) -> (BooleanMatrix -> [BooleanMatrix]) -> BooleanMatrix -> [BooleanMatrix]
handleME func els m = [ foldl1 func r | r <- subsequences $ els m, r /= [] ]

{-- returns a list of all possible disj/conj of rows/columns --}
disjSomeRows, disjSomeColumns, conjSomeRows, conjSomeColumns :: BooleanMatrix -> [BooleanMatrix]
disjSomeRows = handleME disj rows
disjSomeColumns = handleME disj columns
conjSomeRows = handleME conj rows
conjSomeColumns = handleME conj columns

row, column :: BooleanMatrix -> Int -> BooleanMatrix
row    m@((xi,xj),_) r | r <= xi && r > 0 = ((1,xj), [ m !* (r,j) | j <- [1..xj] ])
                       | otherwise = indexError "row"
column m@((xi,xj),x) c | c <= xj && c > 0 = ((xi,1), [ m !* (i,c) | i <- [1..xi] ])
                       | otherwise = indexError $ "column" ++ show (xi,xj) ++ show x

rows, columns :: BooleanMatrix -> [BooleanMatrix]
rows m@((xi,xj),x) = map (row m) [1..xi]
columns m@((xi,xj),x) = map (column m) [1..xj]

addRows, addColumns :: BooleanMatrix -> BooleanMatrix -> BooleanMatrix
addRows    m1@((xi,xj),x) m2@((yi,yj),y) | xj == yj = ((xi+yi,xj), x ++ y)
                                         | (xi,xj) == (0,0) = m2
                                         | (yi,yj) == (0,0) = m1
                                         | otherwise = dimensionsError "addRows"
addColumns m1@((xi,xj),x) m2@((yi,yj),y) | xi == yi = ((xi,xj+yj), concatMap (\c -> (matrix2Int $ row m1 c) ++ (matrix2Int $ row m2 c)) [1..xi])
                                         | (xi,xj) == (0,0) = m2
                                         | (yi,yj) == (0,0) = m1
                                         | otherwise = dimensionsError "addRows"

removeRow, removeColumn :: BooleanMatrix -> Int -> BooleanMatrix
removeRow m@((xi,xj),x) r | r <= xi && r > 0 = int2Matrix (xi-1,xj) $ concatMap (snd . row m) [ i | i <- [1..xi], i /= r ]
                          | otherwise = indexError "removeRow"
removeColumn m@((xi,xj),x) c | xj == 1 = ((xi,0),[])
                             | c <= xj && c > 0 = foldl1 addColumns $ map (column m) [ i | i <- [1..xj], i /= c ]
                             | otherwise = indexError "removeColumn"

basisColumns, basisRows :: BooleanMatrix -> BooleanMatrix
basisColumns m = go m ((0,0),[])
    where go m buffer | empty m = buffer
          go m buffer | (not $ empty buffer) && (elem (column m 1) (disjSomeColumns buffer)) = go (removeColumn m 1) buffer
                      | otherwise = go (removeColumn m 1) (addColumns buffer (column m 1))

basisRows m = go m ((0,0),[])
    where go m buffer | empty m = buffer
          go m buffer | (not $ empty buffer) && (elem (row m 1) (disjSomeRows buffer)) = go (removeRow m 1) buffer
                      | otherwise = go (removeRow m 1) (addRows buffer (row m 1))

testOperations = runTestTT $ TestList [ test_empty, test_disjColumns, test_removeColumn, test_basicColumns ]
    where
        test_empty = TestCase $ assertEqual "" True ( empty e )
        test_disjColumns = TestCase $ do
            assertEqual "" ((3,1),[1,1,1]) ( disjColumns x )
            assertEqual "" v ( disjColumns v )
        test_removeColumn = TestCase $ assertEqual "" ((3,2),[0,1,0,0,0,1]) ( removeColumn x 1 )
        test_basicColumns = TestCase $ assertEqual "" x ( basisColumns x )
        e = int2Matrix (0,0) []
        x = int2Matrix (3,3) [1,0,1,1,0,0,0,0,1]
        v = int2Matrix (3,1) [1,1,0]

{--
 -- Matrix Properties
 --}
primaryIdempotent, secondaryIdempotent :: BooleanMatrix -> Bool
primaryIdempotent   x = x /= idempotent x
secondaryIdempotent x = x == idempotent x

fromRClassM, fromLClassM :: BooleanMatrix -> BooleanMatrix -> Bool
fromRClassM m1 m2 = (sortColumns $ basisColumns m1) == (sortColumns $ basisColumns m2)
fromLClassM m1 m2 = (sortRows    $ basisRows m1   ) == (sortRows    $ basisRows m2   )

fromRClass, fromLClass :: BooleanMatrix -> BooleanMatrix -> Bool
fromRClass a b = ( isJust . find (a ==) $ map (multC b) (allMatrixs (ck,cm)) ) &&
                 ( isJust . find (b ==) $ map (multC a) (allMatrixs (cm,ck)) )
    where (_, cm) = bounds_ a
          (_, ck) = bounds_ b

fromLClass a b = ( isJust . find (a ==) $ map (`multC` b) (allMatrixs (cn,ck)) ) &&
                 ( isJust . find (b ==) $ map (`multC` a) (allMatrixs (ck,cn)) )
    where (cn, _) = bounds_ a
          (ck, _) = bounds_ b

{--
 -- Some data
 --}
allMatrixs :: (Int, Int) -> [BooleanMatrix]
allMatrixs (i, j) = map (int2Matrix (i,j)) $ replicateM (i*j) [0,1]

identityMatrix :: (Int, Int) -> BooleanMatrix
identityMatrix (i, j) = int2Matrix (i,j) $ replicate (i*j) 1