module TerraHS.Algebras.Base.Category where
import Prelude hiding (map, zip)
import qualified Prelude
class Funct f where
unlift :: f a -> a
($*$) :: f (a->b) -> f a -> f b
lift0 :: a -> f a
lift1:: (a->b) -> f a -> f b
lift2 :: (a->b->c) -> f a -> f b -> f c
lift3 :: (a->b->c->d) -> f a -> f b -> f c -> f d
lift4 :: (a->b->c->d->e) -> f a -> f b -> f c -> f d -> f e
instance Funct [] where
unlift [a] = a
lift0 a = [a]
lift1 = Prelude.map
lift2 = Prelude.zipWith
lift3 f [] _ _ = []
lift3 f _ [] _ = []
lift3 f _ _ [] = []
lift3 f (a:as) (b:bs) (c:cs) = (f a b c) : (lift3 f as bs cs)
class Relations r o m | r -> o m where
tgt :: r a b -> o b
src :: r a b -> o a
arrow :: r a b -> m a b
type Relation o m a b = ( m a b , o a, o b )
instance Relations Fun [] (->) where
src (Fun ( f, a, b) ) = a
tgt (Fun ( f, a, b) ) = b
arrow (Fun ( f, a, b) ) = f
class (Relations f o m) => Function f o m | f -> o m where
fold1 :: (b -> b -> b) ->(f a b)-> b
dom :: f a b -> [a]
cod :: f a b -> [b]
fun :: f a b -> (a -> b)
newtype Fun a b = Fun (Relation ([]) (->) a b)
instance Function Fun ([]) (->) where
fold1 f fi = foldr1 f (cod fi)
dom f = src f
cod f = lift1 (fun f) (dom f)
fun f = arrow f
new_fun f domain = Fun (f , domain, [])
new_fun1 domain codomain = Fun (f1 , domain, [])
where
pair = (domain, codomain)
f1 i = (retrieve1 pair i)
retrieve1 :: (Eq a) => ([a], [b]) -> a -> b
retrieve1 (obs, ids) id1 = retrieve' (filter ((== id1) . fst ) (Prelude.zip obs ids) )
where
retrieve' (xs) = snd (head xs)
eval :: (Eq a) => Fun a b -> a -> Maybe b
eval f o
| (( elem o (dom f) ) == True ) = Just ((fun f) o)
| otherwise = Nothing
eval' :: (Eq a) => (Maybe (Fun a b)) -> a -> Maybe b
eval' Nothing _ = Nothing
eval' (Just f) o
| (( elem o (dom f) ) == True ) = Just ((fun f) o)
| otherwise = Nothing