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