module REL

where 

import List
import SetOrd

divisors :: Integer -> [(Integer,Integer)]
divisors n = [ (d, quot n d)  | d <- [1..k], rem n d == 0 ] 
   where k = floor (sqrt (fromInteger n))

prime'' :: Integer -> Bool
prime'' = \n -> divisors n == [(1,n)]

divs :: Integer -> [Integer]
divs n = (fst list) ++ reverse (snd list)
   where list = unzip (divisors n)

properDivs :: Integer -> [Integer]
properDivs n = init (divs n)

perfect :: Integer -> Bool 
perfect n = sum (properDivs n) == n 

type Rel a = Set (a,a)

domR :: Ord a => Rel a -> Set a
domR (Set r) = list2set [ x | (x,_) <- r ]

ranR :: Ord a => Rel a -> Set a
ranR (Set r) = list2set [ y | (_,y) <- r ]

idR :: Ord a => Set a -> Rel a 
idR (Set xs) = Set [(x,x) | x <- xs]

totalR :: Set a -> Rel a
totalR (Set xs) = Set [(x,y) | x <- xs, y <- xs ]

invR :: Ord a => Rel a -> Rel a
invR (Set []) = (Set [])
invR (Set ((x,y):r)) = insertSet (y,x) (invR (Set r))

inR :: Ord a => Rel a -> (a,a) -> Bool
inR r (x,y) = inSet (x,y) r 

complR :: Ord a => Set a -> Rel a -> Rel a
complR (Set xs) r = 
   Set [(x,y) | x <- xs, y <- xs, not (inR r (x,y))]

reflR :: Ord a => Set a -> Rel a -> Bool
reflR set r = subSet (idR set) r 

irreflR :: Ord a => Set a -> Rel a -> Bool
irreflR (Set xs) r = 
   all (\ pair  -> not (inR r pair)) [(x,x) | x <- xs]

symR :: Ord a => Rel a -> Bool
symR (Set []) = True 
symR (Set ((x,y):pairs)) | x == y = symR (Set pairs)
                         | otherwise = 
                           inSet (y,x) (Set pairs) 
                           && symR (deleteSet (y,x) (Set pairs))

transR :: Ord a => Rel a -> Bool
transR (Set []) = True
transR (Set s) = and [ trans pair (Set s) | pair <- s ] where 
      trans (x,y) (Set r) = 
       and [ inSet (x,v) (Set r) | (u,v) <- r, u == y ] 

composePair :: Ord a => (a,a) -> Rel a -> Rel a
composePair (x,y) (Set []) = Set []
composePair (x,y) (Set ((u,v):s)) 
   | y == u    = insertSet (x,v) (composePair (x,y) (Set s))
   | otherwise = composePair (x,y) (Set s)

unionSet :: (Ord a) => Set a -> Set a -> Set a 
unionSet (Set [])     set2  =  set2
unionSet (Set (x:xs)) set2  = 
   insertSet x (unionSet (Set xs) (deleteSet x set2))

compR :: Ord a => Rel a -> Rel a -> Rel a 
compR (Set []) _ = (Set [])
compR (Set ((x,y):s)) r = 
   unionSet (composePair (x,y) r) (compR (Set s) r) 

repeatR :: Ord a => Rel a -> Int -> Rel a 
repeatR r n | n < 1     = error "argument < 1"
            | n == 1    = r 
            | otherwise = compR r (repeatR r (n-1))

r = Set [(0,2),(0,3),(1,0),(1,3),(2,0),(2,3)]
r2 = compR r r 
r3 = repeatR r 3
r4 = repeatR r 4

s = Set [(0,0),(0,2),(0,3),(1,0),(1,2),(1,3),(2,0),(2,2),(2,3)]
test = (unionSet r (compR s r)) == s

divides :: Integer -> Integer -> Bool
divides d n | d == 0    = error "divides: zero divisor"
            | otherwise = (rem n d) == 0

eq :: Eq a => (a,a) -> Bool
eq = uncurry (==) 

lessEq :: Ord a => (a,a) -> Bool
lessEq = uncurry (<=)

inverse :: ((a,b) -> c) -> ((b,a) -> c)
inverse f (x,y) = f (y,x)

type Rel' a = a -> a -> Bool

emptyR' :: Rel' a 
emptyR' = \ _ _ -> False 

list2rel' :: Eq a => [(a,a)] -> Rel' a 
list2rel' xys = \ x y -> elem (x,y) xys

idR' :: Eq a => [a] -> Rel' a
idR' xs = \ x y -> x == y && elem x xs 

invR' :: Rel' a -> Rel' a
invR' = flip

inR' :: Rel' a -> (a,a) -> Bool
inR' = uncurry  

reflR' :: [a] -> Rel' a -> Bool
reflR' xs r = and [ r x x | x <- xs ]

irreflR' :: [a] -> Rel' a -> Bool
irreflR' xs r = and [ not (r x x) | x <- xs ]

symR' :: [a] -> Rel' a -> Bool
symR' xs r = and [ not (r x y && not (r y x)) | x <- xs, y <- xs ]

transR' :: [a] -> Rel' a -> Bool
transR' xs r = and 
              [ not (r x y && r y z && not (r x z)) 
                       | x <- xs, y <- xs, z <- xs ]

unionR' :: Rel' a -> Rel' a -> Rel' a 
unionR' r s x y = r x y  || s x y 

intersR' :: Rel' a -> Rel' a -> Rel' a 
intersR' r s x y = r x y && s x y 

reflClosure' :: Eq a => Rel' a -> Rel' a 
reflClosure' r = unionR' r (==) 

symClosure' :: Rel' a -> Rel' a 
symClosure' r = unionR' r (invR' r) 

compR' :: [a] -> Rel' a -> Rel' a -> Rel' a 
compR' xs r s x y = or [ r x z && s z y | z <- xs ]

repeatR' :: [a] -> Rel' a -> Int -> Rel' a 
repeatR' xs r n | n < 1     = error "argument < 1"
                | n == 1    = r 
                | otherwise = compR' xs r (repeatR' xs r (n-1))

equivalenceR :: Ord a => Set a -> Rel a -> Bool 
equivalenceR set r = reflR set r && symR r && transR r 

equivalenceR' :: [a] -> Rel' a -> Bool 
equivalenceR' xs r = reflR' xs r && symR' xs r && transR' xs r 

modulo :: Integer -> Integer -> Integer -> Bool
modulo n = \ x y -> divides n (x-y)

equalSize :: [a] -> [b] -> Bool
equalSize list1 list2 = (length list1) == (length list2)

type Part = [Int]
type CmprPart = (Int,Part)

expand :: CmprPart -> Part
expand (0,p) = p
expand (n,p) = 1:(expand ((n-1),p))

nextpartition :: CmprPart -> CmprPart
nextpartition (k,(x:xs)) = pack (x-1) ((k+x),xs)

pack :: Int -> CmprPart -> CmprPart
pack 1 (m,xs) = (m,xs)
pack k (m,xs) = if k > m  then pack (k-1) (m,xs) 
                else           pack k     (m-k,k:xs)

generatePs :: CmprPart -> [Part] 
generatePs p@(n,[])     = [expand p]
generatePs p@(n,(x:xs)) = 
      (expand p: generatePs(nextpartition p))

part :: Int -> [Part] 
part n | n < 1     = error "part: argument <= 0"
       | n == 1    = [[1]]
       | otherwise = generatePs (0,[n])