Relational Algebra

module RelationalAlgebra(innerJoin,transitiveClosure) where

import Data.List(sort,nubBy)
import Control.Arrow((***))

----------------------------------------------------------------------
-- RELATIONAL ALGEBRA

ifKeyMatchesAddValue seekKey (findKey,value) =
                  if seekKey === findKey then (:) value
                                         else id

lookupAll   seekKey      = foldr (ifKeyMatchesAddValue seekKey) []
lookupAllIn keyValueDict = flip lookupAll keyValueDict

-- PRE : abDict and bcDict are set-like
-- POST: Returned   acDict is  set-like
innerJoin :: (Ord a, Ord b, Ord c) => [(a, b)] -> [(b, c)] -> [(a, c)]
innerJoin abDict bcDict  = concatMap innerJoinFor joinKeys
  where getKeys          = map fst
                 `andThen` removeDupsFromSorted
        joinKeys         = getKeys abDict
        joinedValues     = lookupAllIn abDict
                 `andThen` concatMap (lookupAllIn bcDict)
                 `andThen` sortAndRemoveDups
        innerJoinFor     = dup -- key into (joinKey,seekKey)
                 `andThen` (repeat       {- joinKey -} ***
                            joinedValues {- seekKey -})
                 `andThen` uncurry zip   -- (joinKey,joinedValues)

-- PRE : Arg is set-like
-- POST: Returned is set-like, transitiveClosure is idempotent
transitiveClosure :: (Ord a) => [(a, a)] -> [(a, a)]
transitiveClosure  aaDict
      | aaDict === aaDictNew = aaDictNew
      | otherwise            = transitiveClosure aaDictNew
  where aaDictNew            = mergeInSelfJoin aaDict
        mergeInSelfJoin d    = d `merge` innerJoin d d

----------------------------------------------------------------------
-- USING LISTS AS SETS

-- DEF: A list is set-like if it is in strictly increasing order

-- Why is this not in Prelude?
dup x = (x,x)

-- I prefer reading function composition from left-to-right
andThen = flip (.)

-- Uses < instead of == to preserve set-like structures
x === y = not (x < y || y < x)

-- PRE : Arg is sorted
-- POST: Result is set-like
removeDupsFromSorted :: Ord a => [a] -> [a]
removeDupsFromSorted = nubBy (===)

-- POST: Result is set-like
sortAndRemoveDups :: Ord a => [a] -> [a]
sortAndRemoveDups = sort
          `andThen` removeDupsFromSorted

-- PRE : Args  are set-like
-- POST: Result is set-like, the sorted union of args
merge as []  = as
merge []  bs = bs
merge aas@(a:as) bbs@(b:bs) | a < b     = a : merge as  bbs
                            | b < a     = b : merge aas bs
                            | otherwise = a : merge as  bs