Permalink
Browse files

IncrementalCategorical.hs with attribute algebra

  • Loading branch information...
1 parent e2c76f5 commit 002bb8393c193b2a0fa7c23c074689b83a57f1d6 @spl committed Apr 4, 2009
Showing with 399 additions and 0 deletions.
  1. +399 −0 IncrementalCategorical2.hs
@@ -0,0 +1,399 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module IncrementalCategorical2 where
+
+import Prelude hiding (succ)
+import Text.Show
+import Text.Read
+
+--------------------------------------------------------------------------------
+-- "Normal" fixed point
+--------------------------------------------------------------------------------
+
+newtype Mu f = In { out :: f (Mu f) }
+
+instance (Eq (f (Mu f))) => Eq (Mu f) where
+ In f == In g = f == g
+
+instance (Ord (f (Mu f))) => Ord (Mu f) where
+ In f `compare` In g = f `compare` g
+
+instance (Show (f (Mu f))) => Show (Mu f) where
+ showsPrec d (In f) = showParen (d > 10) $ showString "In " . showsPrec 11 f
+
+instance (Read (f (Mu f))) => Read (Mu f) where
+ readPrec = parens . prec 10 $ do
+ Ident "In " <- lexP
+ f <- step readPrec
+ return (In f)
+
+--------------------------------------------------------------------------------
+-- "Attributed" fixed point
+--------------------------------------------------------------------------------
+
+-- Attribute: a triple of an inherited tag, a synthesized tag, and a functor.
+data Att i s f r = Att { itag :: i, stag :: s, fun :: f r }
+ deriving (Eq, Ord, Show, Read)
+
+-- Attributed fixed point: every recursive point is now a triple with the two
+-- attributes and the original recursive point.
+type AMu i s f = Mu (Att i s f)
+
+fork :: (a -> b) -> (a -> c) -> a -> (b, c)
+fork f g x = (f x, g x)
+
+result :: AMu i s f -> (i, s)
+result = fork itag stag . out
+
+iresult :: AMu i s f -> i
+iresult = fst . result
+
+sresult :: AMu i s f -> s
+sresult = snd . result
+
+--------------------------------------------------------------------------------
+-- Algebra and Coalgebra classes
+--------------------------------------------------------------------------------
+
+-- Attribute algebra
+class (Functor f) => AAlgebra f i s where
+ asyn :: i -> f (AMu i s f) -> (s, f (AMu i s f))
+
+--------------------------------------------------------------------------------
+-- Types for specific algebras
+--------------------------------------------------------------------------------
+
+data None = None deriving (Eq, Ord, Show, Read)
+
+newtype Size = Size { getSize :: Int } deriving (Eq, Ord, Show, Read, Num)
+
+newtype Sum = Sum { getSum :: Int } deriving (Eq, Ord, Show, Read, Num)
+
+--------------------------------------------------------------------------------
+-- Isomorphism between AMu and the unattributed functor
+--------------------------------------------------------------------------------
+
+ain' :: (Functor f) => (i -> f (AMu i s f) -> (s, f (AMu i s f))) -> i -> f (AMu i s f) -> AMu i s f
+ain' sho i x = In (Att i s y)
+ where
+ (s, y) = sho i x
+
+ain :: forall f i s. (AAlgebra f i s) => i -> f (AMu i s f) -> AMu i s f
+ain = ain' asyn
+
+-- Was: forget
+aout :: AMu i s f -> (f (AMu i s f), i)
+aout = fork fun itag . out
+
+--------------------------------------------------------------------------------
+-- Typical morphisms
+--------------------------------------------------------------------------------
+
+-- Catamorphism
+
+cata' :: (Functor f) => (f a -> i -> a) -> AMu i s f -> a
+cata' phi x = let (f, i) = aout x in phi (fmap (cata' phi) f) i
+
+-- Anamorphism
+
+-- TODO
+
+-- Hylomorphism
+
+-- A more general version
+hylo_g' :: (Functor f) => (a -> f a) -> (g b -> b) -> (forall c. f c -> g c) -> a -> b
+hylo_g' psi phi e = phi . e . fmap (hylo_g' psi phi e) . psi
+
+hylo' :: (Functor f) => (f b -> b) -> (a -> f a) -> a -> b
+hylo' phi psi = phi . fmap (hylo' phi psi) . psi
+
+-- Paramorphism
+
+-- This is simply a pair with record syntax to document the fields. 'inp' is
+-- the original input value. 'rec' is the result of a recursive call.
+data Para i s f a = Para { inp :: AMu i s f, rec :: a }
+
+instance Functor (Para i s f) where
+ fmap f (Para v a) = Para v (f a)
+
+data Wrap i s f a = Wrap { unWrap :: f (Para i s f a), unInh :: i }
+
+instance (Functor f) => Functor (Wrap i s f) where
+ fmap f x = Wrap (fmap (fmap f) (unWrap x)) (unInh x)
+
+para' :: (Functor f) => (f (Para i s f a) -> i -> a) -> AMu i s f -> a
+para' phi = hylo' (uncurry phi . fork unWrap unInh) psi
+ where
+ psi x = let (f, i) = aout x in Wrap (fmap pair f) i
+ pair x = Para x x
+
+-- Zygomorphism
+
+-- TODO
+
+--------------------------------------------------------------------------------
+-- Nat
+--------------------------------------------------------------------------------
+
+-- Tree functor
+
+data NatF r = Z | S r deriving (Eq, Ord, Show, Read)
+
+instance Functor NatF where
+ fmap f n =
+ case n of
+ Z -> Z
+ S m -> S (f m)
+
+-- "Normal" and "Attributed" Nat types
+
+type Nat = Mu NatF
+type ANat i s = AMu i s NatF
+
+-- Smart constructors
+
+zero :: (AAlgebra NatF i s) => i -> ANat i s
+zero i = ain i Z
+
+succ :: (AAlgebra NatF i s) => i -> ANat i s -> ANat i s
+succ i n = ain i (S n)
+
+-- "Library" functions
+
+add :: (AAlgebra NatF i s) => ANat i s -> ANat i s -> ANat i s
+add m = cata' phi
+ where
+ phi Z _ = m
+ phi (S n) i = succ i n
+
+mul :: (AAlgebra NatF i s) => ANat i s -> ANat i s -> ANat i s
+mul m = cata' phi
+ where
+ phi Z i = zero i
+ phi (S n) _ = add m n
+
+fac :: (AAlgebra NatF i s) => ANat i s -> ANat i s
+fac = para' phi
+ where
+ phi Z i = succ i (zero i)
+ phi (S p) i = mul (succ i (inp p)) (rec p)
+
+toNat :: (Num a, AAlgebra NatF i s) => i -> a -> ANat i s
+toNat i 0 = zero i
+toNat i x
+ | signum x == -1 = undefined
+ | otherwise = succ i (toNat i (x - 1))
+
+fromNat :: ANat i s -> Integer
+fromNat = cata' phi
+ where
+ phi Z _ = 0
+ phi (S n) _ = 1 + n
+
+-- Examples
+
+instance AAlgebra NatF None None where
+ asyn _ x = (None, x)
+
+testNat1 :: ANat None None
+testNat1 = toNat None (4 :: Int)
+
+testNat2 :: ANat None None
+testNat2 = fac testNat1
+
+instance AAlgebra NatF Size Size where
+ asyn i x =
+ case x of
+ Z -> (i, Z)
+ S n -> (1 + sresult n, S n)
+
+testNat3 :: ANat Size Size
+testNat3 = toNat (Size 7) (4 :: Int)
+
+--------------------------------------------------------------------------------
+-- Tree
+--------------------------------------------------------------------------------
+
+-- Tree functor
+
+data TreeF a r = Bin a r r | Tip deriving (Eq, Ord, Show, Read)
+
+instance Functor (TreeF a) where
+ fmap f t =
+ case t of
+ Bin a x y -> Bin a (f x) (f y)
+ Tip -> Tip
+
+-- "Normal" and "Extended" Tree types
+
+type Tree a = Mu (TreeF a)
+type ATree i s a = AMu i s (TreeF a)
+
+-- Smart constructors
+
+bin :: (AAlgebra (TreeF a) i s) => i -> a -> ATree i s a -> ATree i s a -> ATree i s a
+bin i a x y = ain i (Bin a x y)
+
+tip :: (AAlgebra (TreeF a) i s) => i -> ATree i s a
+tip i = ain i Tip
+
+-- "Library" functions
+
+-- Insert with direct recursion
+insert_rec :: (Ord a, AAlgebra (TreeF a) i s) => a -> ATree i s a -> ATree i s a
+insert_rec a t =
+ case aout t of
+ (Tip, i) ->
+ bin i a (tip i) (tip i)
+ (Bin b x y, i) ->
+ case compare a b of
+ LT -> bin i b (insert_rec a x) y
+ GT -> bin i b x (insert_rec a y)
+ EQ -> bin i a x y
+
+-- Insert as a paramorphism
+insert :: (Ord a, AAlgebra (TreeF a) i s) => a -> ATree i s a -> ATree i s a
+insert a = para' phi
+ where
+ phi Tip i =
+ bin i a (tip i) (tip i)
+ phi (Bin b x y) i =
+ case compare a b of
+ LT -> bin i b (rec x) (inp y)
+ GT -> bin i b (inp x) (rec y)
+ EQ -> bin i a (inp x) (inp y)
+
+toTree :: (Ord a, AAlgebra (TreeF a) i s) => i -> [a] -> ATree i s a
+toTree i = foldr insert (tip i)
+
+-- Examples
+
+testTree :: (AAlgebra (TreeF Int) i s) => i -> ATree i s Int
+testTree i = toTree i [1,9,2,8,3,7]
+
+-- No algebra
+
+instance AAlgebra (TreeF a) None None where
+ asyn _ x = (None, x)
+
+testTreeNone :: ATree None None Int
+testTreeNone = testTree None
+
+-- Size algebra
+
+instance AAlgebra (TreeF a) Size Size where
+ asyn (Size i) t =
+ case t of
+ Tip ->
+ (Size i, Tip)
+ Bin a x y ->
+ (Size (1 + sz x + sz y), Bin a x y)
+ where
+ sz = getSize . sresult
+
+testTreeSize :: Int
+testTreeSize = getSize $ sresult (testTree 1 :: ATree Size Size Int)
+
+-- Sum algebra
+
+instance AAlgebra (TreeF Int) None Sum where
+ asyn _ t =
+ case t of
+ Tip ->
+ (0, Tip)
+ Bin a x y ->
+ (Sum a + sresult x + sresult y, Bin a x y)
+
+testTreeSum :: Int
+testTreeSum = getSum $ sresult $ testTree None
+
+-- Float difference algebra
+
+newtype DiffI = DI { avg :: Float } deriving (Eq, Ord, Show, Read)
+data DiffS = DS { sumD :: Float, len :: Float, res :: Float } deriving (Eq, Ord, Show, Read)
+
+instance AAlgebra (TreeF Float) DiffI DiffS where
+ asyn i t =
+ case t of
+ Tip ->
+ (DS { sumD = 0, len = 0, res = 0 }, Tip)
+ Bin n x y ->
+ (DS { sumD = n + sumD sx + sumD sy, len = 1 + len sx + len sy, res = n - avg i }, Bin n x y)
+ where
+ sx = sresult x
+ sy = sresult y
+
+average :: (Fractional a) => [a] -> a
+average x = sum x / (fromIntegral (length x))
+
+testTreeDiff :: (AAlgebra (TreeF Float) DiffI DiffS) => ATree DiffI DiffS Float
+testTreeDiff = val
+ where
+ val = toTree i [1,9,2,8,3,7]
+ s = sresult val
+ i = DI { avg = sumD s / len s }
+
+--------------------------------------------------------------------------------
+-- List
+--------------------------------------------------------------------------------
+
+-- List functor
+
+data ListF a r = Cons a r | Nil deriving (Eq, Ord, Show, Read)
+
+instance Functor (ListF a) where
+ fmap f l =
+ case l of
+ Cons a as -> Cons a (f as)
+ Nil -> Nil
+
+-- "Normal" and "Extended" List types
+
+type List a = Mu (ListF a)
+type AList i s a = AMu i s (ListF a)
+
+-- Smart constructors
+
+cons :: (AAlgebra (ListF a) i s) => i -> a -> AList i s a -> AList i s a
+cons i a as = ain i (Cons a as)
+
+nil :: (AAlgebra (ListF a) i s) => i -> AList i s a
+nil i = ain i Nil
+
+-- "Library" functions
+
+toList :: (AAlgebra (ListF a) i s) => i -> [a] -> AList i s a
+toList i = foldr (cons i) (nil i)
+
+-- Examples
+
+testList :: (AAlgebra (ListF Int) i s) => i -> AList i s Int
+testList i = toList i [1,9,2,8,3,7]
+
+instance AAlgebra (ListF a) Size Size where
+ asyn i l =
+ case l of
+ Nil -> (i, Nil)
+ Cons a as -> (1 + sresult as, Cons a as)
+
+testListSize :: Int
+testListSize = getSize $ sresult (testList 1 :: AList Size Size Int)
+
+instance AAlgebra (ListF Int) None Sum where
+ asyn _ l =
+ case l of
+ Nil ->
+ (0, Nil)
+ Cons a as ->
+ (Sum a + sresult as, Cons a as)
+
+testListSum :: Int
+testListSum = getSum $ sresult (testList None :: AList None Sum Int)
+

0 comments on commit 002bb83

Please sign in to comment.