Skip to content
Browse files

switched to Edward Kmett's Control.Comonad package

  • Loading branch information...
1 parent 4662385 commit 9302559640d647dd70e39b86bdfc6e343216e27f @dorchard committed Aug 22, 2012
Showing with 153 additions and 66 deletions.
  1. +21 −7 Context.lhs
  2. +22 −15 Language/Haskell/Codo.lhs
  3. +56 −21 arrays.lhs
  4. +15 −8 edit-distance-array.lhs
  5. +27 −6 edit-distance-trans.lhs
  6. +3 −3 lucid-streams.lhs
  7. +9 −6 num-functions.lhs
View
28 Context.lhs
@@ -1,15 +1,19 @@
> module Context where
> import Data.Monoid
-> import Control.Comonad.Alt
+> import Control.Comonad
InContext or CoState comonad - models context-aware computations
> data InContext c a = InContext (c -> a) c
> instance Comonad (InContext c) where
-> current (InContext s c) = s c
-> k <<= (InContext s c) = InContext (\c' -> k (InContext s c')) c
+> extract (InContext s c) = s c
+> extend k (InContext s c) = InContext (\c' -> k (InContext s c')) c
+
+> instance Functor (InContext c) where
+> fmap f = extend (f . extract)
+
> at :: InContext c a -> c -> a
> at (InContext s _) c' = s c'
@@ -20,8 +24,18 @@ InContext or CoState comonad - models context-aware computations
Param or exponent comonad - models context-oblivious computations
-> data Param x a = Param (x -> a)
+ instance Monoid x => Comonad ((->) x) where
+ extract f = f mempty
+ extend k f = (\x' -> k (\x -> f (mappend x x')))
+
+ instance Monoid x => Functor ((->) x) where
+ fmap f = extend (f . extract)
+
+Product comonad
+
+ instance Comonad ((,) x) where
+ extract (x, a) = a
+ extend f (x, a) = (x, f (x, a))
-> instance Monoid x => Comonad (Param x) where
-> current (Param f) = f mempty
-> k <<= (Param f) = Param (\x' -> k (Param (\x -> f (mappend x x'))))
+ instance Functor ((,) x) where
+ fmap f = extend (f . extract)
View
37 Language/Haskell/Codo.lhs
@@ -19,7 +19,7 @@
> import Debug.Trace
> import Data.Char
-> import Control.Comonad.Alt
+> import Control.Comonad
> fv var = varE $ mkName var
@@ -103,35 +103,37 @@
> -- Top-level translation
> codoMain :: Exp -> Q Exp
-> codoMain (LamE p bs) = [| $(codoMain' (LamE p bs)) . (cmap $(return $ projFun p)) |]
+> codoMain (LamE p bs) = [| $(codoMain' (LamE p bs)) . (fmap $(return $ projFun p)) |]
> codoMain' :: Exp -> Q Exp
-> codoMain' (LamE [TupP ps] (DoE stms)) = let p (VarP v) = [v]
-> p (WildP) = [mkName "_reserved_gamma_"]
-> p (TupP ps) = concatMap p ps
-> p _ = error codoPatternError
-> in codoBind stms (concatMap p ps)
+> codoMain' (LamE [TupP ps] (DoE stms)) = codoBind stms (concatMap patToVarPs ps)
> codoMain' (LamE [WildP] (DoE stms)) = codoBind stms [mkName "_reserved_gamma_"]
> codoMain' (LamE [VarP v] (DoE stms)) = codoBind stms [v]
> codoMain' _ = error codoPatternError
> codoPatternError = "Malformed codo: codo must start with either a variable, wildcard, or tuple pattern (of wildcards or variables)"
> -- create the projection function to arrange the codo-Block parameters into the correct ordder
+> patToVarPs :: Pat -> [Name]
> patToVarPs (TupP ps) = concatMap patToVarPs ps
-> patToVarPs WildP = [VarE $ mkName "undefined"]
-> patToVarPs (VarP v) = [VarE v]
+> patToVarPs WildP = [mkName "_reserved_gamma_"]
+> patToVarPs (VarP v) = [v]
> patToVarPs _ = error "Only tuple, variable, or wildcard patterns currently allowed"
> projExp [] = TupE []
> projExp (x:xs) = TupE [x, (projExp xs)]
-> projFun p = LamE p (projExp (concatMap patToVarPs p))
+> projFun p = LamE (map replaceWild p) (projExp (map VarE (concatMap patToVarPs p)))
+
+> replaceWild WildP = VarP $ mkName "_reserved_gamma_"
+> replaceWild x = x
> -- **********************
> -- ii). bindings transformations
> -- **********************
+> convert lVars envVars = LamE [TupP [TupP (map VarP lVars),
+> TupP ((map VarP envVars) ++ [TupP []])]] (projExp (map VarE (lVars ++ envVars)))
> -- Note all these functions for making binders take a variable which is the "gamma" variable
> -- Binding interpretation (\vdash_c)
@@ -140,9 +142,9 @@
> codoBind [NoBindS e] vars = [| \gamma -> $(envProj vars (transformM (doToCodo) e)) gamma |]
> codoBind [x] vars = error "Codo block must end with an expressions"
> codoBind ((NoBindS e):bs) vars = [| $(codoBind bs vars) .
-> (cobind (\gamma ->
+> (extend (\gamma ->
> ($(envProj vars (transformM (doToCodo) e)) gamma,
-> coreturn gamma))) |]
+> extract gamma))) |]
> codoBind ((LetS [ValD (VarP v) (NormalB e) []]):bs) vars =
> [| (\gamma ->
@@ -151,9 +153,14 @@
> codoBind ((BindS (VarP v) e):bs) vars = [| $(codoBind bs (v:vars)) .
-> (cobind (\gamma ->
+> (extend (\gamma ->
+> ($(envProj vars (transformM (doToCodo) e)) gamma,
+> extract gamma))) |]
+> codoBind ((BindS (TupP ps) e):bs) vars = [| $(codoBind bs ((concatMap patToVarPs ps) ++ vars)) .
+> (extend (\gamma ->
+> $(return $ convert (concatMap patToVarPs ps) vars)
> ($(envProj vars (transformM (doToCodo) e)) gamma,
-> coreturn gamma))) |]
+> extract gamma))) |]
> codoBind _ _ = error "Ill-formed codo bindings"
> doToCodo :: Exp -> Q Exp
@@ -175,7 +182,7 @@
> envProj vars exp = let gam = mkName "gamma" in (lamE [varP gam] (letE (projs vars (varE gam)) exp))
> -- Make a comonadic projection
-> mkProj gam (v, n) = valD (varP v) (normalB [| cmap $(prj n) $(gam) |]) []
+> mkProj gam (v, n) = valD (varP v) (normalB [| fmap $(prj n) $(gam) |]) []
> -- Creates a list of projections
> projs :: [Name] -> ExpQ -> [DecQ]
View
77 arrays.lhs
@@ -1,19 +1,26 @@
> {-# LANGUAGE TemplateHaskell #-}
> {-# LANGUAGE QuasiQuotes #-}
-> import Control.Comonad.Alt
+> import Control.Comonad
> import Language.Haskell.Codo
> import Data.Array
+> class Comonad c => ComonadZip c where
+> czip :: (c a, c b) -> c (a, b)
+
+
> data PArray i a = PA (Array i a) i deriving Show
> instance Ix i => Comonad (PArray i) where
-> current (PA arr c) = arr!c
-> f <<= (PA x c) =
+> extract (PA arr c) = arr!c
+> extend f (PA x c) =
> let es' = map (\i -> (i, f (PA x i))) (indices x)
> in PA (array (bounds x) es') c
+> instance Ix i => Functor (PArray i) where
+> fmap f = extend (f . extract)
+
> laplace1D :: Fractional a => PArray Int a -> a
> laplace1D (PA a i) =
> let (b1, b2) = bounds a
@@ -25,11 +32,14 @@
> data PBArray i a = PBA (Array i a) i (i, i) deriving Show
> instance Ix i => Comonad (PBArray i) where
-> current (PBA arr c _) = arr!c
-> f <<= (PBA x c b) =
+> extract (PBA arr c _) = arr!c
+> extend f (PBA x c b) =
> let es' = map (\i -> (i, f (PBA x i b))) (indices x)
> in PBA (array (bounds x) es') c b
+> instance Ix i => Functor (PBArray i) where
+> fmap f = extend (f . extract)
+
> withInterior :: Ord i => (PBArray i a -> b) -> (PBArray i a -> b) -> (PBArray i a -> b)
> withInterior f g x@(PBA a c (b1, b2)) = if (c>=b1 && c<b2)
@@ -43,14 +53,14 @@
> laplace1Db :: Fractional a => PBArray Int a -> a
> laplace1Db = (\(PBA a i _) -> a!(i-1) - 2*(a!i) + a!(i+1))
-> `withExterior` current
+> `withExterior` extract
> localMean1Db :: Fractional a => PBArray Int a -> a
> localMean1Db = (\(PBA a i _) -> (a!(i-1) + a!i + a!(i+1)) / 3.0)
-> `withExterior` current
+> `withExterior` extract
> filterC :: Comonad c => (a -> Bool) -> a -> c a -> a
-> filterC p x a = if p (current a) then x else current a
+> filterC p x a = if p (extract a) then x else extract a
Example array values
@@ -63,10 +73,10 @@ Example array values
> prog1 = [codo| x => y <- laplace1Db x
> z <- localMean1Db y
-> current z |]
+> extract z |]
> plus :: (Comonad c, Num a) => c a -> c a -> a
-> plus x y = current x + current y
+> plus x y = extract x + extract y
> prog2 = [codo| a => b <- localMean1Db a
> c <- laplace1Db b
@@ -93,7 +103,7 @@ Example array values
> prog3 = [codo| (x, y) => a <- laplace1Db x
> b <- laplace1Db y
-> (current a) + (current b) |]
+> (extract a) + (extract b) |]
prog3 <<= (czip (x, y))
@@ -130,29 +140,29 @@ Other expermintation with abstractions on boundary testing
> b' <- b `withBoundary` a
> c <- localMean1Dc b'
> c' <- c `withBoundary` a
-> d <- (current b') `min` (current c')
+> d <- (extract b') `min` (extract c')
> filterC (<0.3) 0.3 d |]
> boo4 = [codo| a => b <- laplace1Dc a
> b' <- b `withBoundary` a
> c <- localMean1Dc b'
> c' <- c `withBoundary` a
-> d <- (current b') `min` (current c')
+> d <- (extract b') `min` (extract c')
> w <- localMean1Dc d
> w `withBoundary` a |]
> boo4' = [codo| a => b <- laplace1Dc a
> b' <- b `withExterior'` a
> c <- localMean1Dc b'
> c' <- c `withExterior'` a
-> d <- (current b') `min` (current c')
+> d <- (extract b') `min` (extract c')
> w <- localMean1Dc d
> w `withExterior'` a|]
-> boo4'' = [codo| a => b <- laplace1Dc `withExterior` current $ a
-> c <- localMean1Dc `withExterior` current $ b
-> d <- (current b) `min` (current c)
-> localMean1Dc `withExterior` current $ d |]
+> boo4'' = [codo| a => b <- laplace1Dc `withExterior` extract $ a
+> c <- localMean1Dc `withExterior` extract $ b
+> d <- (extract b) `min` (extract c)
+> localMean1Dc `withExterior` extract $ d |]
@@ -165,10 +175,35 @@ Other expermintation with abstractions on boundary testing
> laplace1D y |]
> prog2a = [codo| x => y <- laplace1D x
-> z <- (current x) + (current y)
-> current z |]
+> z <- (extract x) + (extract y)
+> extract z |]
> prog3a = [codo| x => y <- laplace1D x
-> z <- (current x) + (current y)
+> z <- (extract x) + (extract y)
> laplace1D z |]
+
+> -- ==================== 2D arrays ==============
+
+> -- To simplify code, make tuples of numbers a number type themselves
+> instance (Num a, Num b) => Num (a, b) where
+> (x, y) + (a, b) = (x + a, y + b)
+> (x, y) - (a, b) = (x - a, y - b)
+> (x, y) * (a, b) = (x * a, y * b)
+> abs (x, y) = (abs x, abs y)
+> signum (x, y) = (signum x, signum y)
+> fromInteger x = (fromInteger x, fromInteger x)
+
+
+> laplace2D, gauss2D :: Fractional a => PArray (Int, Int) a -> a
+> laplace2D a = a ? (-1, 0) + a ? (1, 0) + a ? (0, -1) + a ? (0, 1) - 4 * a ? (0, 0)
+> gauss2D a = (a ? (-1, 0) + a ? (1, 0) + a ? (0, -1) + a ? (0, 1) + 2 * a ? (0, 0)) / 6.0
+
+> (?) :: (Ix i, Num a, Num i) => PArray i a -> i -> a
+> (PA a i) ? i' = if (inRange (bounds a) (i+i')) then a!(i+i') else 0
+
+> contours :: PArray (Int, Int) Float -> Float
+> contours = [codo| x => y <- gauss2D x
+> z <- gauss2D y
+> w <- (extract y) - (extract z)
+> laplace2D w |]
View
23 edit-distance-array.lhs
@@ -4,7 +4,7 @@
> {-# LANGUAGE FlexibleInstances #-}
> import Language.Haskell.Codo
-> import Control.Comonad.Alt
+> import Control.Comonad
> import Data.Monoid
> import Data.Array.IArray
@@ -14,19 +14,23 @@ Usea an array to do dynamic programming as opposed to the (inefficient) InContex
> data DynP x a = DynP (Array (Int, Int) a) [x] [x] (Int, Int) ((Int, Int), (Int, Int))
> instance Comonad (DynP x) where
-> current (DynP a _ _ c _) = a ! c
+> extract (DynP a _ _ c _) = a ! c
-> f <<= (DynP a x y c (b1, b2)) =
+> extend f (DynP a x y c (b1, b2)) =
> let es = map (\c' -> (c', f (DynP a x y c' (b1, b2)))) (range (b1, b2))
> a' = array (b1, b2) es
> in DynP a' x y c (b1, b2)
+> instance Functor (DynP x) where
+> fmap f = extend (f . extract)
+
+
Levenshtein edit-distance algorithms
> levenshtein :: DynP Char Int -> Int
> levenshtein = [codo| _ => -- Initialise first row and column
> d <- levenshtein _
-> dn <- (coreturn d) + 1
+> dn <- (extract d) + 1
> d0 <- (constant 0) `fbyX` dn
> d' <- d0 `fbyY` dn
> -- Shift (-1, 0), (0, -1), (-1, -1)
@@ -35,10 +39,10 @@ Levenshtein edit-distance algorithms
> d_nw <- d !!! (-1, -1)
> -- Body
> d'' <- if (correspondingX d == correspondingY d) then
-> coreturn d_nw
-> else minimum [(coreturn d_w) + 1,
-> (coreturn d_n) + 1,
-> (coreturn d_nw) + 1]
+> extract d_nw
+> else minimum [(extract d_w) + 1,
+> (extract d_n) + 1,
+> (extract d_nw) + 1]
> d' `thenXY` d'' |]
> edit_distance x y = levenshtein <<= (DynP undefined (' ':x) (' ':y) (0, 0) ((0, 0), (length x, length y)))
@@ -100,6 +104,9 @@ Not used in this example
> prod :: [a] -> [b] -> [(a, b)]
> prod xs ys = xs >>= (\x' -> ys >>= (\y' -> return (x', y')))
+> class Comonad c => ComonadZip c where
+> czip :: (c a, c b) -> c (a, b)
+
> -- pre condition: the dyn prog paramerters are equal
> instance ComonadZip (DynP x) where
> czip ((DynP s l t c@(c1, c2) ((bx0, by0), (bxn, byn))),
View
33 edit-distance-trans.lhs
@@ -5,7 +5,7 @@
> {-# LANGUAGE TypeOperators #-}
> import Language.Haskell.Codo
-> import Control.Comonad.Alt
+> import Control.Comonad
> import Data.Monoid
> import Control.Compose
@@ -16,19 +16,40 @@ as the composite of the InContext and product comonads.
> type DynP x = ((,) ([x], [x])) :. (InContext (Int, Int))
+> -- Distributive law between comonads
+> class ComonadDist c d where
+> cdist :: c (d a) -> d (c a)
+
+> -- The composite of any two comonads with a (coherence preserving) distributive law
+> -- forms a comonad
+> instance (Comonad c, Comonad d, ComonadDist c d) => Comonad (c :. d) where
+> extract (O x) = extract . extract $ x
+> duplicate (O x) = O . (fmap (fmap O)) . (fmap cdist) . (fmap (fmap duplicate)) . duplicate $ x
+
+
+> -- Comonad transformers
+> class ComonadTrans t where
+> liftC :: Comonad c => t c a -> c a
+
+> -- Comonad transformer for composites
+> class ComonadTransComp t where
+> liftC_comp :: Comonad c => (t :. c) a -> c a
+
+
> instance ComonadDist ((,) x) (InContext s) where
> cdist (x, InContext s c) = InContext (\c -> (x, s c)) c
> instance ComonadTransComp ((,) x) where
> liftC_comp (O (x, a)) = a
+
Levenshtein edit-distance algorithms
> levenshtein :: DynP Char Int -> Int
> levenshtein = [codo| _ => -- Initialise first row and column
> d <- levenshtein _
-> dn <- (coreturn d) + 1
+> dn <- (extract d) + 1
> d0 <- (constant 0) `fbyXl` dn
> d' <- d0 `fbyYl` dn
> -- Shift (-1, 0), (0, -1), (-1, -1)
@@ -37,10 +58,10 @@ Levenshtein edit-distance algorithms
> d_nw <- d !!! (-1, -1)
> -- Body
> d'' <- if (correspondingX d == correspondingY d) then
-> coreturn d_nw
-> else minimum [(coreturn d_w) + 1,
-> (coreturn d_n) + 1,
-> (coreturn d_nw) + 1]
+> extract d_nw
+> else minimum [(extract d_w) + 1,
+> (extract d_n) + 1,
+> (extract d_nw) + 1]
> d' `thenXYl` d'' |]
> edit_distance x y = levenshtein <<= (O ((' ':x, ' ':y), InContext undefined (0, 0)))
View
6 lucid-streams.lhs
@@ -4,7 +4,7 @@
> {-# LANGUAGE NoMonomorphismRestriction #-}
-> import Control.Comonad.Alt
+> import Control.Comonad
> import Language.Haskell.Codo
> import Context
@@ -21,15 +21,15 @@
> -- fib = 0 fby 1 fby (fib + next fib)
> fib' :: Num a => Stream () -> a
> fib' = [codo| _ => fib <- fib' _
-> fibn2 <- (next fib) + (current fib)
+> fibn2 <- (next fib) + (extract fib)
> fibn1 <- (constant 1) `fby` fibn2
> (constant 0) `fby` fibn1 |]
> fib = fib' <<= (constant ())
> -- Example of nested tuple patterns
-> tup3 = [codo| (x, (y, z)) => a <- (current y) + (current z)
+> tup3 = [codo| (x, (y, z)) => a <- (extract y) + (extract z)
> x `fby` a |]
Stream operations
View
15 num-functions.lhs
@@ -4,7 +4,7 @@
> {-# LANGUAGE NoMonomorphismRestriction #-}
> import Language.Haskell.Codo
-> import Control.Comonad.Alt
+> import Control.Comonad
> import Data.Monoid
> import Data.Array
> import Text.Printf
@@ -32,25 +32,28 @@ Minima testing function
> minima = [codo| f => f' <- differentiate f
> f'' <- differentiate f'
-> (current f'' `roughlyEqual` 0) && (current f'' < 0) |]
+> (extract f'' `roughlyEqual` 0) && (extract f'' < 0) |]
Macluarin approximations
> m3 = [codo| (f, x) => f' <- differentiate f
> f'' <- differentiate f'
-> (f (-current x))
-> + (f' (-current x)) * (coreturn x)
-> + (f'' (-current x)) / 2 * (coreturn x)**2 |]
+> (f (-extract x))
+> + (f' (-extract x)) * (extract x)
+> + (f'' (-extract x)) / 2 * (extract x)**2 |]
> m3' = [codo| (f, xf) => f' <- differentiate f
> f'' <- differentiate f'
-> let x = coreturn xf
+> let x = extract xf
> (f (-x))
> + (f' (-x)) * x
> + ((f'' (-x)) / 2) * x**2 |]
Zipping operations
+> class Comonad c => ComonadZip c where
+> czip :: (c a, c b) -> c (a, b)
+
> instance Monoid x => ComonadZip ((->) x) where
> czip (f, g) = \x -> (f x, g x)

0 comments on commit 9302559

Please sign in to comment.
Something went wrong with that request. Please try again.