501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt{- |

8e5fce1f9ceba17dd7e3ff0eb287e1e999c14249Mark AndrewsModule : $Header$

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntDescription : signaturefor Relational Schemes

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntCopyright : Dominik Luecke, Uni Bremen 2008

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntLicense : GPLv2 or higher or LIZENZ.txt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntMaintainer : luecke@informatik.uni-bremen.de

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntStability : provisional

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntPortability : portable

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntSignature for Relational Schemes

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt-}

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntmodule RelationalScheme.Sign

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt (

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt RSIsKey

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSDatatype(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSRawSymbol

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSColumn(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSTable(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSTables(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , Sign

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSMorphism(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSTMap(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , emptyRSSign

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , isRSSubsig

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , concatComma

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , idMor

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , rsInclusion

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , uniteSig

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , comp_rst_mor

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , RSSymbol(..)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt )

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt where

4eb998928b9aef0ceda42d7529980d658138698aEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport RelationalScheme.Keywords

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.AS_Annotation

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.Doc

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.DocUtils

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.Id

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.Result

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport Common.Utils

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport qualified Data.Map as Map

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntimport qualified Data.Set as Set

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunttype RSIsKey = Bool

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntdata RSDatatype = RSboolean | RSbinary | RSdate | RSdatetime | RSdecimal | RSfloat |

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt RSinteger | RSstring | RStext | RStime | RStimestamp | RSdouble |

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt RSnonPosInteger | RSnonNegInteger | RSlong | RSPointer

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt deriving (Eq, Ord)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunttype RSRawSymbol = Id

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntdata RSSymbol = STable Id | -- id of a table

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt SColumn

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt Id -- id of the symbol

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt Id -- id of the table

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt RSDatatype -- datatype of the symbol

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt RSIsKey -- is it a key?

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt deriving (Eq,Ord,Show)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntinstance GetRange RSSymbol

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntdata RSColumn = RSColumn

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt {

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt c_name :: Id

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , c_data :: RSDatatype

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , c_key :: RSIsKey

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt }

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt deriving (Eq, Ord)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntdata RSTable = RSTable

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt {

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt t_name :: Id

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , columns :: [RSColumn]

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , rsannos :: [Annotation]

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt , t_keys :: Set.Set (Id, RSDatatype)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt }

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt deriving (Eq)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntdata RSTables = RSTables

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt {

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt tables :: Set.Set RSTable

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt }

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt deriving (Eq, Ord)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Huntinstance GetRange RSTables

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntisRSSubsig :: RSTables -> RSTables -> Bool

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntisRSSubsig t1 t2 = t1 <= t2

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntuniteSig :: (Monad m) => RSTables -> RSTables -> m RSTables

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan HuntuniteSig s1 s2 =

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt if s1 `isRSSubsig` s2

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt then

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt return $ RSTables $ (tables s1) `Set.union` (tables s2)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt else

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt if s2 `isRSSubsig` s1

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt then

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt return $ RSTables $ (tables s1) `Set.union` (tables s2)

501941f0b6cce74c2ff75b10aff3f230d5d37e4cEvan Hunt else

if s1 `isDisjoint` s2 then

return $ RSTables $ (tables s1) `Set.union` (tables s2)

else

fail ("Tables " ++ (show s1) ++ " and " ++ (show s2) ++

" cannot be united.")

type Sign = RSTables

data RSTMap = RSTMap

{

col_map :: Map.Map Id Id

}

deriving (Eq, Ord, Show)

data RSMorphism = RSMorphism

{ domain :: RSTables

, codomain :: RSTables

, table_map :: Map.Map Id Id

, column_map :: Map.Map Id RSTMap

}

deriving (Eq, Ord, Show)

-- I hope that this works right, I do not want to debug this

apply_comp_c_map :: RSTable -> Map.Map Id Id -> RSMorphism -> RSMorphism

-> (Id, RSTMap)

apply_comp_c_map rst t_map imap imor =

let i = t_name rst

c2 = column_map imor

in case Map.lookup i $ column_map imap of

Just iM -> case Map.lookup (Map.findWithDefault i i t_map) c2 of

Just iM2 ->

let c_set = Map.fromList . map (\ c -> (c_name c, ())) $ columns rst

oM = composeMap c_set (col_map iM) (col_map iM2)

in (i, RSTMap oM)

Nothing -> (i, iM)

Nothing -> (i, Map.findWithDefault (RSTMap Map.empty)

(Map.findWithDefault i i t_map) c2)

-- composition of Rel morphisms

comp_rst_mor :: RSMorphism -> RSMorphism -> Result RSMorphism

comp_rst_mor mor1 mor2 =

let d1 = domain mor1

t1 = Set.toList $ tables d1

t_set = Map.fromList $ map (\ t -> (t_name t, ())) t1

t_map = composeMap t_set (table_map mor1) (table_map mor2)

cm_map = Map.fromList

$ map (\x -> apply_comp_c_map x t_map mor1 mor2) t1

in return RSMorphism

{ domain = d1

, codomain = codomain mor2

, table_map = t_map

, column_map = cm_map

}

emptyRSSign :: RSTables

emptyRSSign = RSTables

{

tables = Set.empty

}

-- ^ id-morphism for RS

idMor :: RSTables -> RSMorphism

idMor t = RSMorphism

{

domain = t

, codomain = t

, table_map = foldl (\y x -> Map.insert (t_name x) (t_name x) y) Map.empty $

Set.toList $ tables t

, column_map =

let

makeRSTMap i =

foldl (\y x -> Map.insert (c_name x) (c_name x) y) Map.empty $

columns i

in

foldl (\y x -> Map.insert (t_name x) (RSTMap $ makeRSTMap x) y)

Map.empty $ Set.toList $ tables t

}

rsInclusion :: RSTables -> RSTables -> Result RSMorphism

rsInclusion t1 t2 = return $ RSMorphism

{

domain = t1

, codomain = t2

, table_map = foldl (\y x -> Map.insert (t_name x) (t_name x) y) Map.empty $

Set.toList $ tables t1

, column_map =

let

makeRSTMap i =

foldl (\y x -> Map.insert (c_name x) (c_name x) y) Map.empty $

columns i

in

foldl (\y x -> Map.insert (t_name x) (RSTMap $ makeRSTMap x) y)

Map.empty $ Set.toList $ tables t1

}

-- pretty printing stuff

instance Show RSColumn where

show c = (if c_key c

then rsKey ++ " "

else "") ++ (show $ c_name c) ++ ":" ++ (show $ c_data c)

instance Show RSTable where

show t = (show $ t_name t) ++ "(" ++ concatComma (map show $ columns t) ++ ")"

instance Show RSTables where

show t = rsTables ++ "\n" ++

(unlines $ map show $ Set.toList $ tables t)

instance Pretty RSTables where

pretty = text . show

instance Pretty RSMorphism where

pretty = text . show

instance Pretty RSSymbol where

pretty = text . show

instance Show RSDatatype where

show dt = case dt of

RSboolean -> rsBool

RSbinary -> rsBin

RSdate -> rsDate

RSdatetime -> rsDatetime

RSdecimal -> rsDecimal

RSfloat -> rsFloat

RSinteger -> rsInteger

RSstring -> rsString

RStext -> rsText

RStime -> rsTime

RStimestamp -> rsTimestamp

RSdouble -> rsDouble

RSnonPosInteger -> rsNonPosInteger

RSnonNegInteger -> rsNonNegInteger

RSlong -> rsLong

RSPointer -> rsPointer

concatComma :: [String] -> String

concatComma [] = ""

concatComma (x:[]) = x

concatComma (x:xs) = x ++ ", " ++ concatComma xs

-- we need an explicit instance declaration of Ord that

-- correctly deals with tables

isSubtable :: RSTable -> RSTable -> Bool

isSubtable t1 t2 =

let

sc1 = Set.fromList $ columns t1

sc2 = Set.fromList $ columns t2

in

t_name t1 == t_name t2 && sc1 `Set.isSubsetOf` sc2

isProperSubtable :: RSTable -> RSTable -> Bool

isProperSubtable t1 t2 =

let

sc1 = Set.fromList $ columns t1

sc2 = Set.fromList $ columns t2

in

t_name t1 == t_name t2 && sc1 `Set.isProperSubsetOf` sc2

isDisjoint ::RSTables -> RSTables -> Bool

isDisjoint s1 s2 =

let

t1 = Set.map t_name $ (tables) s1

t2 = Set.map t_name $ (tables) s2

in

Set.fold (\x y -> y && (x `Set.notMember` t2)) True t1 &&

Set.fold (\x y -> y && (x `Set.notMember` t1)) True t2

instance Ord RSTable where

x <= y = x `isSubtable` y

x < y = x `isProperSubtable` y

x >= y = y `isProperSubtable` x

x > y = y `isSubtable` x