Friday, April 20, 2007

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