GTALib 0.0.4 → 0.0.5
raw patch · 7 files changed
+571/−73 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- GTA.Data.BinTree: instance [overlap ok] GenericSemiringStructure (BinTreeAlgebra n0 l0) (BinTree n0 l0) (BinTreeMapFs n0 l0)
- GTA.Data.BinTree: instance [overlap ok] GenericSemiringStructure (LVTreeAlgebra a0) (LVTree a0) (LVTreeMapFs a0)
- GTA.Data.ConsList: instance [overlap ok] GenericSemiringStructure (ConsListAlgebra a0) (ConsList a0) (ConsListMapFs a0)
- GTA.Data.JoinList: instance [overlap ok] GenericSemiringStructure (JoinListAlgebra a0) (JoinList a0) (JoinListMapFs a0)
+ GTA.Data.BinTree: instance [overlap ok] GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l)
+ GTA.Data.BinTree: instance [overlap ok] GenericSemiringStructure (LVTreeAlgebra b) (LVTree b) (LVTreeMapFs b)
+ GTA.Data.BinTree: type BinTreeSemiring n l a = GenericSemiring (BinTreeAlgebra n l) a
+ GTA.Data.BinTree: type LVTreeSemiring a s = GenericSemiring (LVTreeAlgebra a) s
+ GTA.Data.ConsList: data ConsListMapFs b b'
+ GTA.Data.ConsList: instance [overlap ok] GenericSemiringStructure (ConsListAlgebra b) (ConsList b) (ConsListMapFs b)
+ GTA.Data.JoinList: data JoinListMapFs b b'
+ GTA.Data.JoinList: instance [overlap ok] GenericSemiringStructure (JoinListAlgebra b) (JoinList b) (JoinListMapFs b)
+ GTA.Data.JoinList: joinListAlgebra :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a
+ GTA.Data.JoinList: prop_Associativity :: Eq b => JoinListAlgebra a b -> (b, b, b) -> Bool
+ GTA.Data.JoinList: prop_Identity :: Eq b => JoinListAlgebra a b -> b -> Bool
- GTA.Core: (<.>) :: t -> t1 -> (t, t1)
+ GTA.Core: (<.>) :: (b -> Bool) -> alg b -> (b -> Bool, alg b)
- GTA.Data.BinTree: BinTreeAlgebra :: (n_abRT -> gta -> gta -> gta) -> (l_abRU -> gta) -> BinTreeAlgebra n_abRT l_abRU gta
+ GTA.Data.BinTree: BinTreeAlgebra :: (n -> a -> a -> a) -> (l -> a) -> BinTreeAlgebra n l a
- GTA.Data.BinTree: BinTreeMapFs :: (n_abRT -> gta) -> (l_abRU -> gta) -> BinTreeMapFs n_abRT l_abRU gta
+ GTA.Data.BinTree: BinTreeMapFs :: (n -> b') -> (l -> b') -> BinTreeMapFs n l b'
- GTA.Data.BinTree: LVTreeAlgebra :: (gta -> gta -> gta) -> (a_abOb -> gta) -> LVTreeAlgebra a_abOb gta
+ GTA.Data.BinTree: LVTreeAlgebra :: (a -> a -> a) -> (b -> a) -> LVTreeAlgebra b a
- GTA.Data.BinTree: LVTreeMapFs :: (a_abOb -> gta) -> LVTreeMapFs a_abOb gta
+ GTA.Data.BinTree: LVTreeMapFs :: (b -> b') -> LVTreeMapFs b b'
- GTA.Data.BinTree: binLeaf :: BinTreeAlgebra n_abRT l_abRU gta -> l_abRU -> gta
+ GTA.Data.BinTree: binLeaf :: BinTreeAlgebra n l a -> l -> a
- GTA.Data.BinTree: binLeafF :: BinTreeMapFs n_abRT l_abRU gta -> l_abRU -> gta
+ GTA.Data.BinTree: binLeafF :: BinTreeMapFs n l b' -> l -> b'
- GTA.Data.BinTree: binNode :: BinTreeAlgebra n_abRT l_abRU gta -> n_abRT -> gta -> gta -> gta
+ GTA.Data.BinTree: binNode :: BinTreeAlgebra n l a -> n -> a -> a -> a
- GTA.Data.BinTree: binNodeF :: BinTreeMapFs n_abRT l_abRU gta -> n_abRT -> gta
+ GTA.Data.BinTree: binNodeF :: BinTreeMapFs n l b' -> n -> b'
- GTA.Data.BinTree: data BinTreeAlgebra n_abRT l_abRU gta
+ GTA.Data.BinTree: data BinTreeAlgebra n l a
- GTA.Data.BinTree: data BinTreeMapFs n_abRT l_abRU gta
+ GTA.Data.BinTree: data BinTreeMapFs n l b'
- GTA.Data.BinTree: data LVTreeAlgebra a_abOb gta
+ GTA.Data.BinTree: data LVTreeAlgebra b a
- GTA.Data.BinTree: data LVTreeMapFs a_abOb gta
+ GTA.Data.BinTree: data LVTreeMapFs b b'
- GTA.Data.BinTree: leafLV :: LVTreeAlgebra a_abOb gta -> a_abOb -> gta
+ GTA.Data.BinTree: leafLV :: LVTreeAlgebra b a -> b -> a
- GTA.Data.BinTree: leafLVF :: LVTreeMapFs a_abOb gta -> a_abOb -> gta
+ GTA.Data.BinTree: leafLVF :: LVTreeMapFs b b' -> b -> b'
- GTA.Data.BinTree: nodeLV :: LVTreeAlgebra a_abOb gta -> gta -> gta -> gta
+ GTA.Data.BinTree: nodeLV :: LVTreeAlgebra b a -> a -> a -> a
- GTA.Data.ConsList: ConsListAlgebra :: (a_ajxE -> gta -> gta) -> gta -> ConsListAlgebra a_ajxE gta
+ GTA.Data.ConsList: ConsListAlgebra :: (b -> a -> a) -> a -> ConsListAlgebra b a
- GTA.Data.ConsList: cons :: ConsListAlgebra a_ajxE gta -> a_ajxE -> gta -> gta
+ GTA.Data.ConsList: cons :: ConsListAlgebra b a -> b -> a -> a
- GTA.Data.ConsList: data ConsListAlgebra a_ajxE gta
+ GTA.Data.ConsList: data ConsListAlgebra b a
- GTA.Data.ConsList: nil :: ConsListAlgebra a_ajxE gta -> gta
+ GTA.Data.ConsList: nil :: ConsListAlgebra b a -> a
- GTA.Data.JoinList: JoinListAlgebra :: (gta -> gta -> gta) -> (a_agmG -> gta) -> gta -> JoinListAlgebra a_agmG gta
+ GTA.Data.JoinList: JoinListAlgebra :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a
- GTA.Data.JoinList: data JoinListAlgebra a_agmG gta
+ GTA.Data.JoinList: data JoinListAlgebra b a
- GTA.Data.JoinList: nil :: JoinListAlgebra a_agmG gta -> gta
+ GTA.Data.JoinList: nil :: JoinListAlgebra b a -> a
- GTA.Data.JoinList: single :: JoinListAlgebra a_agmG gta -> a_agmG -> gta
+ GTA.Data.JoinList: single :: JoinListAlgebra b a -> b -> a
- GTA.Data.JoinList: times :: JoinListAlgebra a_agmG gta -> gta -> gta -> gta
+ GTA.Data.JoinList: times :: JoinListAlgebra b a -> a -> a -> a
Files
- GTALib.cabal +24/−2
- src/GTA/Core.hs +121/−10
- src/GTA/Data/BinTree.hs +69/−47
- src/GTA/Data/ConsList.hs +37/−2
- src/GTA/Data/JoinList.hs +251/−3
- src/GTA/Util/GenericSemiringStructureTemplate.hs +64/−5
- src/GTA/Util/TypeInfo.hs +5/−4
GTALib.cabal view
@@ -7,13 +7,35 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.0.4 +Version: 0.0.5 -- A short (one-line) description of the package. Synopsis: A library for GTA programming -- A longer description of the package. -Description: This package provides the core functionalities of the GTA (Generate, Test, and Aggregate) programming framework on Haskell (c.f., Kento Emoto, Sebastian Fischer, Zhenjiang Hu: Generate, Test, and Aggregate - A Calculation-based Framework for Systematic Parallel Programming with MapReduce. ESOP 2012: 254-273). (This version is a very early version and dirty. The source files will be cleaned and documented soon.) +Description: + This package provides the core functionalities of the GTA (Generate, Test, and Aggregate) programming framework on Haskell (c.f., Kento Emoto, Sebastian Fischer, Zhenjiang Hu: Generate, Test, and Aggregate - A Calculation-based Framework for Systematic Parallel Programming with MapReduce. ESOP 2012: 254-273. The authors' version is available at <http://www.ipl-lab.org/~emoto/ESOP2012.pdf>). + . + /Example/ + . + The following code is a GTA program to solve the 0-1 Knapsack problem (<http://en.wikipedia.org/wiki/Knapsack_problem>). It /appears to be an exponential cost/ proram in the number of input items, because it appears to generate all item selections by @subsP items@ (/Generate/), discard those with total weight heavier than the knapsack's capacity by @`filterBy` weightlimit capacity@ (/Test/), and take the most valuable selection by @`aggregateBy` maxsumsolutionWith getValue@ (/Aggregate/). However, it /actually runs in a linear time/ owing to our proposed program transformation 'Filter-embedding Semiring Fusion' implemented in the library. In addition, it runs in /parallel/ so that you can get linear speedup. + . + > knapsack capacity items = + > subsP items + > `filterBy` weightlimit capacity + > `aggregateBy` maxsumsolutionWith getValue + > + > getValue (_, v) = v + > getWeight (w, _) = w + > + > weightlimit w = (<=w) <.> weightsum where + > weightsum = joinListAlgebra times single nil --workaround for cabal's brace-eating bug + > x1 `times` x2 = ( x1 + x2) `min` (w+1) + > single i = getWeight i `min` (w+1) + > nil = 0 + . + Several examples of GTA programming are found in /examples/ directory at <https://bitbucket.org/emoto/gtalib/src>. + -- URL for the project homepage or repository. Homepage: https://bitbucket.org/emoto/gtalib
src/GTA/Core.hs view
@@ -1,12 +1,38 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell #-} +{-| + This module provides the core functionalities of the GTA (Generate, Test, and Aggregate) programming framework on Haskell (c.f., Kento Emoto, Sebastian Fischer, Zhenjiang Hu: Generate, Test, and Aggregate - A Calculation-based Framework for Systematic Parallel Programming with MapReduce. ESOP 2012: 254-273. The authors' version is available at <http://www.ipl-lab.org/~emoto/ESOP2012.pdf>). + + /Example of GTA program/ -module GTA.Core (Bag(Bag), CommutativeMonoid (CommutativeMonoid), oplus, identity, GenericSemiring (GenericSemiring), monoid, algebra, GenericSemiringStructure, freeSemiring, liftedSemiring, pairSemiring, shom, hom, makeAlgebra, freeAlgebra, pairAlgebra, foldingAlgebra, bag, (>==), (>=>), (>=<), (>##), (>#>), (<.>), items, revOrd, RevOrd(RevOrd), maxsumBy, maxsumKBy, maxsumsolutionXKBy, maxsumsolutionXBy, maxsumsolutionBy, maxsumsolutionKBy, maxprodBy, maxprodKBy, maxprodsolutionXKBy, maxprodsolutionXBy, maxprodsolutionBy, maxprodsolutionKBy, maxMonoSumBy, maxMonoSumsolutionXBy, maxMonoSumKBy, maxMonoSumsolutionXKBy, addIdentity, AddIdentity (AddIdentity, Identity), sumproductBy, result, filterBy, aggregateBy, transformBy, ) where + The following code is a GTA program to solve the 0-1 Knapsack problem (<http://en.wikipedia.org/wiki/Knapsack_problem>). It /appears to be an exponential cost/ proram in the number of input items, because it appears to generate all item selections by @subsP items@ (/Generate/), discard those with total weight heavier than the knapsack's capacity by @`filterBy` weightlimit capacity@ (/Test/), and take the most valuable selection by @`aggregateBy` maxsumsolutionWith getValue@ (/Aggregate/). However, it /actually runs in a linear time/ owing to our proposed program transformation 'Filter-embedding Semiring Fusion' implemented in the library. In addition, it runs in /parallel/ so that you can get linear speedup. The predicate @weightlimit@ is defined based on the join list algebra given in "GTA.Data.JoinList" module. + > knapsack capacity items = + > subsP items + > `filterBy` weightlimit capacity + > `aggregateBy` maxsumsolutionWith getValue + > + > getValue (_, v) = v + > getWeight (w, _) = w + > + > weightlimit w = (<=w) <.> weightsum where + > weightsum = JoinListAlgebra{..} + > x1 `times` x2 = ( x1 + x2) `min` (w+1) + > single i = getWeight i `min` (w+1) + > nil = 0 + + Several example GTA programs are found in /examples/ directory at <https://bitbucket.org/emoto/gtalib/src>. + + This module provides generic functionalities in the GTA programming framework. Data-strructure-dependent definitions are found in GTA.Data.* modules. + +-} +module GTA.Core (Bag(Bag), CommutativeMonoid (CommutativeMonoid, oplus, identity), GenericSemiring (GenericSemiring, monoid, algebra), GenericSemiringStructure (freeSemiring, liftedSemiring, pairSemiring, shom, hom, makeAlgebra, freeAlgebra, pairAlgebra, foldingAlgebra), bag, (>==), (>=>), (>=<), (>##), (>#>), (<.>), items, revOrd, RevOrd(RevOrd), maxsumBy, maxsumKBy, maxsumsolutionXKBy, maxsumsolutionXBy, maxsumsolutionBy, maxsumsolutionKBy, maxprodBy, maxprodKBy, maxprodsolutionXKBy, maxprodsolutionXBy, maxprodsolutionBy, maxprodsolutionKBy, maxMonoSumBy, maxMonoSumsolutionXBy, maxMonoSumKBy, maxMonoSumsolutionXKBy, addIdentity, AddIdentity (AddIdentity, Identity), sumproductBy, result, filterBy, aggregateBy, transformBy) where + import Data.List import Data.Map (Map,empty, singleton, unionWith,assocs) import Control.DeepSeq -- The bag +{-| A bag is a multiset, i.e., a set in which members are allowed to appear more than one. The order of memebrs is ignored: e.g., @Bag [1,2] == Bag [2,1]@ is True. -} data Bag a = Bag [a] deriving (Show,Ord,Read) instance (NFData a) => (NFData (Bag a)) where @@ -15,9 +41,11 @@ instance (Eq a, Ord a) => Eq (Bag a) where (==) (Bag a) (Bag b) = sort a == sort b +{-| Extracts members from a bag. The order of members is undecidable. -} items :: Bag a -> [a] items (Bag t) = t +{-| Makes a bag that contains the given memebrs. -} bag :: forall a. [a] -> Bag a bag t = Bag t @@ -25,9 +53,21 @@ filterB :: forall a. (a -> Bool) -> Bag a -> Bag a filterB p (Bag b) = Bag (filter p b) +{-| Commutative monoid is an algebra of an associative, commutative binary operator with its identity. -} data CommutativeMonoid a = CommutativeMonoid { - oplus :: a -> a -> a, -- commutative, associative - identity::a -- the identity of oplus + {-| Commutative, associative binary operator: + + > (a `oplus` b) `oplus` c == a `oplus` (b `oplus` c) + > a `oplus` b == b `oplus` a + + -} + oplus :: a -> a -> a, + {-| The identity of `oplus`: + + > a `oplus` identity == identity `oplus` a == a + + -} + identity::a } -- bag is commutative monoid @@ -55,18 +95,40 @@ (oplus2, identity2) = let CommutativeMonoid {..} = m2 in (oplus, identity) -- Generic Semiring +{-| A generic semiring is a combination of a commutative monoid and an algebra such that operators of the algebra distributes over `oplus` and `identity` is the zero of the operators. + +For example, the usual semiring is a combination of a commutative monoid and a 'GTA.Data.JoinList.JoinListAlgebra', in which we have the distributivity and the zeroness: + +> a `times` (b `oplus` c) == (a `times` b) `oplus` (a `times` c) +> (a `oplus` b) `times` c == (a `times` c) `oplus` (b `times` c) +> a `times` identity == identity `times` a == identity + + -} data GenericSemiring alg a = GenericSemiring {monoid :: CommutativeMonoid a, algebra :: alg a} +{-| + Collection of data-structure-dependent definitions necessary for the GTA framework, including the free algebra, lifting of a generic semirig with an algebra, construction of useful algebras, etc. +-} class GenericSemiringStructure alg free uniformer | alg -> free, alg -> uniformer where + {-| The free algebra (i.e., an algebra whose operators are the constructors). -} + freeAlgebra :: alg free + {-| This simply tuples two algebras. -} + pairAlgebra :: alg a -> alg b -> alg (a,b) + {-| This is used to lift a given algebra to the same level as a given monoid so that the combination of the lifted algebra and the monoid is a generic semiring. -} + makeAlgebra :: (CommutativeMonoid m) -> (alg a) -> (m->[a]) -> (a -> m) -> alg m + {-| This is used to make an algebra from a usual binary operator; every operator in the algebra simply combines its operand by the given binary operator. -} + foldingAlgebra :: (a -> a -> a) -> a -> uniformer a -> alg a + {-| The homomorphism from the free algrba, i.e., the catamorphism (used in inefficient impl.). -} + hom :: alg a -> free -> a {- for inefficient impl. -} + {-| Free generic semiring to build a bag of given data structures (such as lists, binary trees, etc.). This is a combination of the bag monoid and the lifted free algebra. -} freeSemiring :: GenericSemiring alg (Bag free) + {-| The most important function to build lifted generic semiring from another generic semiring and an algebra, used in the filter-embedding transformation. -} liftedSemiring :: (Ord c) => GenericSemiring alg a -> alg c -> GenericSemiring alg (Map c a) + {-| This simply tuples two generic semirings. -} pairSemiring :: GenericSemiring alg a -> GenericSemiring alg b -> GenericSemiring alg (a,b) + {-| Homomorphism of a generic semiring (used in inefficient impl.). -} shom :: GenericSemiring alg a -> Bag free -> a {- for inefficient impl. -} - makeAlgebra :: (CommutativeMonoid m) -> (alg a) -> (m->[a]) -> (a -> m) -> alg m - pairAlgebra :: alg a -> alg b -> alg (a,b) - freeAlgebra :: alg free - hom :: alg a -> free -> a {- for inefficient impl. -} freeSemiring = GenericSemiring {..} where monoid = bagMonoid @@ -83,13 +145,13 @@ where monoid' = pairMonoid (monoid s1) (monoid s2) algebra' = pairAlgebra (algebra s1) (algebra s2) - foldingAlgebra :: (a -> a -> a) -> a -> uniformer a -> alg a -- combinators with optimizations -- Generator + Filter = Generator +{-| Combinator for connecting a generator and a filter to build another generator. A fitler is represented by a pair of a judgement function and an algebra. -} infixl 5 >== (>==) :: forall (alg :: * -> *) free (uniformer :: * -> *) c b k. (GenericSemiringStructure alg free uniformer, Ord c) => @@ -103,6 +165,7 @@ in foldr oplus identity [ v | (k, v) <- assocs res, ok k ] -- Generator + Aggregator = Result +{-| Combinator for connecting a generator and an aggregator to get the result. An aggregator is represented by a generic semiring. -} infixl 5 >=> (>=>) :: forall (alg :: * -> *) free (uniformer :: * -> *) b k. (GenericSemiringStructure alg free uniformer) => @@ -110,6 +173,7 @@ (>=>) pgen bts = pgen bts -- Generator_A + Transfomer_{A->B} = Generator_B +{-| Combinator for transforming a generator by a transformer. A transformer is an aggregator polymorphic over another generic semiring. -} infixl 5 >=< (>=<) :: forall (alg :: * -> *) free (uniformer :: * -> *) (alg' :: * -> *) free' (uniformer' :: * -> *) @@ -122,6 +186,7 @@ (>=<) pgen trans = pgen . trans -- aliaces +{-| The same as `>==` -} filterBy :: forall (alg :: * -> *) free (uniformer :: * -> *) c b k. (GenericSemiringStructure alg free uniformer, Ord c) => (GenericSemiring alg (Map c b) -> Map k b) @@ -130,11 +195,13 @@ -> b filterBy = (>==) +{-| The same as `>=>` -} aggregateBy :: forall (alg :: * -> *) free (uniformer :: * -> *) b k. (GenericSemiringStructure alg free uniformer) => (GenericSemiring alg b -> b) -> GenericSemiring alg b -> b aggregateBy = (>=>) +{-| The same as `>=<` -} transformBy :: forall (alg :: * -> *) free (uniformer :: * -> *) (alg' :: * -> *) free' (uniformer' :: * -> *) c. @@ -148,6 +215,7 @@ -- combinators without optimizations +{-| Inefficient version of `>==` (i.e., it does not do optimziation at all). -} infixl 5 >## (>##) :: (GenericSemiringStructure alg free uniformer) => (GenericSemiring alg (Bag free) -> Bag free) @@ -156,6 +224,7 @@ where bag = pgen freeSemiring {-the given semiring will be neglected by the result of this operator -} +{-| Inefficient version of `>=>` (i.e., it does not do optimziation at all). -} infixl 5 >#> (>#>) :: (GenericSemiringStructure alg free uniformer) => (GenericSemiring alg (Bag free) -> Bag free) @@ -164,12 +233,15 @@ -- operator to replace 'ok . hom' by 'ok <.> alg' +{-| Operator to build a pair of a judgement function and an algebra, which represents a Tester. -} infix 6 <.> -(<.>) :: forall t t1. t -> t1 -> (t, t1) +(<.>) :: forall (alg :: * -> *) a b. (b -> Bool) -> alg b -> ((b -> Bool), alg b) (<.>) ok alg = (ok, alg) -- aggregator for generating all candidates passing tests + +{-| The aggregator to extract all items generated by a generator. -} result :: forall (alg :: * -> *) free (uniformer :: * -> *). GenericSemiringStructure alg free uniformer => GenericSemiring alg (Bag free) @@ -191,11 +263,13 @@ identity = iop algebra = foldingAlgebra ot iot mf +{-| The aggregator to compute a sum of products. Each product is of all values in the data structure after /map/. -} sumproductBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a. (GenericSemiringStructure alg free uniformer, Num a) => uniformer a -> GenericSemiring alg a sumproductBy = genAlgebraFromSemiring (+) 0 (*) 1 +{-| Introduces an identity 'Identity' to a given type. -} data AddIdentity a = AddIdentity a | Identity deriving (Show, Eq, Read) instance (Ord a) => Ord (AddIdentity a) where compare Identity Identity = EQ @@ -207,11 +281,16 @@ rnf (AddIdentity a) = rnf a rnf Identity = () +{-| Introduces an identity. -} addIdentity :: forall a. a -> AddIdentity a addIdentity a = AddIdentity a -- max-sum semiring +{-| The aggregator to take the maximum items under a given monotonic sum `mplus` with its identity `mid` after /map/. +> c == a `max` b => d `mplus` (a `max` b) == (d `mplus` a) `max` (d `mplus` b) + +-} maxMonoSumBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a. (GenericSemiringStructure alg free uniformer, Ord a) => (a -> a -> a) @@ -224,6 +303,9 @@ plus (AddIdentity a) (AddIdentity b) = AddIdentity (a `mplus` b) -- max-MonoSum with computation +{-| The tupling of maxMonoSumBy and a given generic semiring. The second component of the result is the aggregation of the maximum items by the given generaic semiring. + +-} maxMonoSumsolutionXBy :: forall free (uniformer :: * -> *) a t (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a) => (a -> a -> a) @@ -245,6 +327,8 @@ (oplus', identity') = let CommutativeMonoid {..} = monoid' in(oplus, identity) -- max-k +{-| The aggregator to find the best k maximum items under a given monotonic sum. An extension of `maxMonoSumBy`. +-} maxMonoSumKBy :: forall a free (uniformer :: * -> *) (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a) => (a -> a -> a) @@ -261,6 +345,8 @@ maxMonoSumAlgebra = let GenericSemiring {..} = maxMonoSumBy mplus mid mf in algebra -- max-solution-k +{-| The /best-k/ extension of `maxMonoSumsolutionXBy`. +-} maxMonoSumsolutionXKBy :: forall a free (uniformer :: * -> *) b (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a) => (a -> a -> a) @@ -285,11 +371,15 @@ (monoid', algebra') = let GenericSemiring {..} = s in (monoid, algebra) -- max-sum +{-| The aggregator to the maximum sum after /map/. +-} maxsumBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a. (GenericSemiringStructure alg free uniformer, Ord a, Num a) => uniformer (AddIdentity a) -> GenericSemiring alg (AddIdentity a) maxsumBy = maxMonoSumBy (+) 0 +{-| The /best-k/ extension of `maxsumBy`. +-} maxsumKBy :: forall a free (uniformer :: * -> *) (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => Int @@ -297,6 +387,8 @@ -> GenericSemiring alg [AddIdentity a] maxsumKBy = maxMonoSumKBy (+) 0 +{-| The /best-k/ extension of `maxsumsolutionXBy`. +-} maxsumsolutionXKBy :: forall a free (uniformer :: * -> *) b (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => GenericSemiring alg b @@ -305,7 +397,8 @@ -> GenericSemiring alg [(AddIdentity a, b)] maxsumsolutionXKBy = maxMonoSumsolutionXKBy (+) 0 - +{-| An instance of `maxMonoSumsolutionXBy` with the usual summation. +-} maxsumsolutionXBy :: forall free (uniformer :: * -> *) a t (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => GenericSemiring alg t @@ -314,6 +407,8 @@ maxsumsolutionXBy = maxMonoSumsolutionXBy (+) 0 +{-| An instance of `maxMonoSumsolutionBy` with the usual summation. +-} maxsumsolutionBy :: forall a (alg :: * -> *) free (uniformer :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => uniformer (AddIdentity a) @@ -321,6 +416,8 @@ maxsumsolutionBy = maxsumsolutionXBy freeSemiring +{-| The /best-k/ extension of `maxsumsolutionBy`. +-} maxsumsolutionKBy :: forall a (alg :: * -> *) free (uniformer :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => Int @@ -329,11 +426,15 @@ maxsumsolutionKBy = maxsumsolutionXKBy freeSemiring --max prod (on positive numbers) +{-| The aggregator to take the maximum product on /non-negative/ numbers. +-} maxprodBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a. (GenericSemiringStructure alg free uniformer, Ord a, Num a) => uniformer (AddIdentity a) -> GenericSemiring alg (AddIdentity a) maxprodBy = maxMonoSumBy (*) 1 +{-| The /best-k/ extension of 'maxprodBy' +-} maxprodKBy :: forall a free (uniformer :: * -> *) (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => Int @@ -342,6 +443,8 @@ maxprodKBy = maxMonoSumKBy (*) 1 +{-| The /best-k/ extension of 'maxprodsolutionXBy' +-} maxprodsolutionXKBy :: forall a free (uniformer :: * -> *) b (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => GenericSemiring alg b @@ -350,6 +453,8 @@ -> GenericSemiring alg [(AddIdentity a, b)] maxprodsolutionXKBy = maxMonoSumsolutionXKBy (*) 1 +{-| The tupling of 'maxprodsolutionBy' and a given generic semiring. The second component of the result is the aggregation of the best items by the given generic emiring. +-} maxprodsolutionXBy :: forall free (uniformer :: * -> *) a t (alg :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => GenericSemiring alg t @@ -357,12 +462,16 @@ -> GenericSemiring alg (AddIdentity a, t) maxprodsolutionXBy = maxMonoSumsolutionXBy (*) 1 +{-| The aggregator to find the items with the maximum product on /non-negative/ numbers. +-} maxprodsolutionBy :: forall a (alg :: * -> *) free (uniformer :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => uniformer (AddIdentity a) -> GenericSemiring alg (AddIdentity a, Bag free) maxprodsolutionBy = maxprodsolutionXBy freeSemiring +{-| The /best-k/ extension of 'maxprodsolutionBy' +-} maxprodsolutionKBy :: forall a (alg :: * -> *) free (uniformer :: * -> *). (GenericSemiringStructure alg free uniformer, Ord a, Num a) => Int @@ -371,9 +480,11 @@ maxprodsolutionKBy = maxprodsolutionXKBy freeSemiring -- reverse order to make `max` `min` +{-| Reverses the order of the argument, so that we can use aggregators maxXXX to take the minimum XXX. -} revOrd :: forall a. a -> RevOrd a revOrd a = RevOrd a +{-| Reverses the order of a given type. -} data RevOrd a = RevOrd a deriving (Eq, Show, Read)
src/GTA/Data/BinTree.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell,TypeSynonymInstances #-} -module GTA.Data.BinTree (LVTree (NodeLV, LeafLV), LVTreeAlgebra(LVTreeAlgebra), nodeLV, leafLV, LVTreeMapFs (LVTreeMapFs), leafLVF, BinTree(BinNode,BinLeaf), BinTreeAlgebra(BinTreeAlgebra),binNode,binLeaf, BinTreeMapFs (BinTreeMapFs), binLeafF, binNodeF, lvtrees, subtreeSelectsWithRoot, subtreeSelects, selects, assignTrans, assignTrees, count, maxsum, maxsumsolution) where +{-| This module provides the GTA framework on binary (and leaf-valued) trees, such as definitions of the data structures and their algebras, generators, aggregators, etc. +-} +module GTA.Data.BinTree (LVTree (NodeLV, LeafLV), LVTreeAlgebra(LVTreeAlgebra, nodeLV, leafLV), LVTreeMapFs (LVTreeMapFs, leafLVF), BinTree(BinNode,BinLeaf), BinTreeAlgebra(BinTreeAlgebra, binNode, binLeaf), BinTreeMapFs (BinTreeMapFs, binLeafF, binNodeF), lvtrees, subtreeSelectsWithRoot, subtreeSelects, selects, assignTrans, assignTrees, count, maxsum, maxsumsolution, LVTreeSemiring, BinTreeSemiring) where import GTA.Core import GTA.Util.GenericSemiringStructureTemplate @@ -11,9 +13,41 @@ | LeafLV a deriving (Eq, Ord, Read) --- automatic generation of things necessary for GTA framework -genAllDecl ''LVTree +-- The following definitions can be generated automatically by @genAllDecl ''LVTree@ +-- They are written by hand here for writing comments. +-- algebra of LVTree +data LVTreeAlgebra b a = LVTreeAlgebra { + nodeLV :: a -> a -> a, + leafLV :: b -> a + } + +-- a set of functions for 'map' +data LVTreeMapFs b b' = LVTreeMapFs { + leafLVF :: b -> b' + } + +-- type parameters are algebra, free algebra, and functions for 'map' +instance GenericSemiringStructure (LVTreeAlgebra b) (LVTree b) (LVTreeMapFs b) where + freeAlgebra = LVTreeAlgebra {..} where + nodeLV = NodeLV + leafLV = LeafLV + pairAlgebra lvta1 lvta2 = LVTreeAlgebra {..} where + nodeLV (l1, l2) (r1, r2) = (nodeLV1 l1 r1, nodeLV2 l2 r2) + leafLV a = (leafLV1 a, leafLV2 a) + (nodeLV1, leafLV1) = let LVTreeAlgebra {..} = lvta1 in (nodeLV, leafLV) + (nodeLV2, leafLV2) = let LVTreeAlgebra {..} = lvta2 in (nodeLV, leafLV) + makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = LVTreeAlgebra {..} where + nodeLV l r = foldr oplus identity [fsingle (nodeLV' l' r') | l' <- frec l, r' <- frec r] + leafLV a = fsingle (leafLV' a) + (nodeLV', leafLV') = let LVTreeAlgebra {..} = lvta in (nodeLV, leafLV) + foldingAlgebra op iop (LVTreeMapFs {..}) = LVTreeAlgebra {..} where + nodeLV l r = l `op` r + leafLV a = leafLVF a + hom (LVTreeAlgebra {..}) = h where + h (NodeLV l r) = nodeLV (h l) (h r) + h (LeafLV a) = leafLV a + -- renaming type LVTreeSemiring a s = GenericSemiring (LVTreeAlgebra a) s @@ -49,54 +83,42 @@ deriving (Eq, Ord, Read) -genAllDecl ''BinTree +-- The following definitions can be generated automatically by @genAllDecl ''BinTree@ +-- They are written by hand here for writing comments. -{- -{- this algebra can be generated automatically from BinTree -} -genAlgebraDecl ''BinTree -{- -data BinTreeAlgebra n l a = - BinTreeAlgebra { - binNode :: n -> a -> a -> a, - binLeaf :: l -> a - } --} -genMapFunctionsDecl ''BinTree --- -- maps to a coherent data --- data BinTreeMapFs n l a = BinTreeMapFs { --- binNodeF :: (n -> a), --- binLeafF :: (l -> a) --- } +-- algebra of BinTree +data BinTreeAlgebra n l a = BinTreeAlgebra { + binNode :: n -> a -> a -> a, + binLeaf :: l -> a + } -{- this instance can be generated automatically from BinTree -} -genInstanceDecl ''BinTree +-- a set of functions for 'map' +data BinTreeMapFs n l b' = BinTreeMapFs { + binNodeF :: n -> b', + binLeafF :: l -> b' + } --- the generic semiring structure of BinTreeALgebra n l --- instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where --- freeAlgebra = BinTreeAlgebra {..} where --- binNode = BinNode --- binLeaf = BinLeaf --- hom (BinTreeAlgebra {..}) = h --- where --- h (BinNode a l r) = binNode a (h l) (h r) --- h (BinLeaf a) = binLeaf a --- pairAlgebra bt1 bt2 = BinTreeAlgebra {..} --- where --- binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2) --- binLeaf a = (binLeaf1 a, binLeaf2 a) --- (binLeaf1, binNode1) = let BinTreeAlgebra {..} = bt1 in (binLeaf, binNode) --- (binLeaf2, binNode2) = let BinTreeAlgebra {..} = bt2 in (binLeaf, binNode) --- makeAlgebra (CommutativeMonoid {..}) bt frec fsingle = BinTreeAlgebra {..} --- where --- binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r] --- binLeaf a = fsingle (binLeaf' a) --- (binLeaf', binNode') = let BinTreeAlgebra {..} = bt in (binLeaf, binNode) --- foldingAlgebra op iop (BinTreeMapFs {binNodeF=(binNodeF1),binLeafF=(binLeafF1)}) = BinTreeAlgebra {..} --- where --- binNode a l r = binNodeF1 a `op` l `op` r --- binLeaf a = binLeafF1 a +-- type parameters are algebra, free algebra, and functions for 'map' +instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where + freeAlgebra = BinTreeAlgebra {..} where + binNode = BinNode + binLeaf = BinLeaf + pairAlgebra lvta1 lvta2 = BinTreeAlgebra {..} where + binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2) + binLeaf a = (binLeaf1 a, binLeaf2 a) + (binNode1, binLeaf1) = let BinTreeAlgebra {..} = lvta1 in (binNode, binLeaf) + (binNode2, binLeaf2) = let BinTreeAlgebra {..} = lvta2 in (binNode, binLeaf) + makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = BinTreeAlgebra {..} where + binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r] + binLeaf a = fsingle (binLeaf' a) + (binNode', binLeaf') = let BinTreeAlgebra {..} = lvta in (binNode, binLeaf) + foldingAlgebra op iop (BinTreeMapFs {..}) = BinTreeAlgebra {..} where + binNode a l r = binNodeF a `op` l `op` r + binLeaf a = binLeafF a + hom (BinTreeAlgebra {..}) = h where + h (BinNode a l r) = binNode a (h l) (h r) + h (BinLeaf a) = binLeaf a --} -- renaming type BinTreeSemiring n l a = GenericSemiring (BinTreeAlgebra n l) a
src/GTA/Data/ConsList.hs view
@@ -5,7 +5,9 @@ (we can make a concise, specialized GTA framework for cons-lists, but...) -} -module GTA.Data.ConsList (ConsList(Cons, Nil), ConsListAlgebra(ConsListAlgebra), cons, nil, consize, deconsize, segs, inits, tails, subs, assigns, assignsBy, paths, mapC, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, crossCons, emptyBag, bagOfNil, bagUnion, ConsSemiring, foldr') where +{-| This module provides the GTA framework on cons lists, such as definitions of the data structure and its algebra, generators, aggregators, etc. +-} +module GTA.Data.ConsList (ConsList(Cons, Nil), ConsListAlgebra(ConsListAlgebra, cons, nil), consize, deconsize, segs, inits, tails, subs, assigns, assignsBy, paths, mapC, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, crossCons, emptyBag, bagOfNil, bagUnion, ConsSemiring, foldr',ConsListMapFs(consF)) where import GTA.Core @@ -19,7 +21,40 @@ -- deriving (Show, Eq, Ord, Read) -- to use the GTA framework -genAllDecl ''ConsList +-- The following definitions can be generated automatically by @genAllDecl ''ConsList@ +-- They are written by hand here for writing comments. + +-- algebra of ConsList +data ConsListAlgebra b a = ConsListAlgebra { + cons :: b -> a -> a, + nil :: a + } + +-- a set of functions for 'map' +data ConsListMapFs b b' = ConsListMapFs { + consF :: b -> b' + } + +-- type parameters are algebra, free algebra, and functions for 'map' +instance GenericSemiringStructure (ConsListAlgebra b) (ConsList b) (ConsListMapFs b) where + freeAlgebra = ConsListAlgebra {..} where + cons = Cons + nil = Nil + pairAlgebra cla1 cla2 = ConsListAlgebra {..} where + cons a (r1, r2) = (cons1 a r1, cons2 a r2) + nil = (nil1, nil2) + (cons1, nil1) = let ConsListAlgebra {..} = cla1 in (cons, nil) + (cons2, nil2) = let ConsListAlgebra {..} = cla2 in (cons, nil) + makeAlgebra (CommutativeMonoid {..}) cla frec fsingle = ConsListAlgebra {..} where + cons a r = foldr oplus identity [fsingle (cons' a r') | r' <- frec r] + nil = fsingle nil' + (cons', nil') = let ConsListAlgebra {..} = cla in (cons, nil) + foldingAlgebra op iop (ConsListMapFs {..}) = ConsListAlgebra {..} where + cons a r = consF a `op` r + nil = iop + hom (ConsListAlgebra {..}) = h where + h (Cons a r) = cons a (h r) + h Nil = nil -- stupid consize function consize :: forall a. [a] -> ConsList a
src/GTA/Data/JoinList.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell #-} -module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra), times, single, nil, joinize, dejoinize, segs, inits, tails, subs, assigns, paths, assignsBy, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP, assignsByP, crossConcat, bagOfSingleton, emptyBag, bagOfNil, bagUnion, Semiring) where +{-| This module provides the GTA framework on join lists, such as definitions of the data structure and its algebra, parallel/serial generators, aggregators, etc. +-} +module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra, times, single, nil), joinize, dejoinize, segs, inits, tails, subs, assigns, paths, assignsBy, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP, assignsByP, crossConcat, bagOfSingleton, emptyBag, bagOfNil, bagUnion, Semiring, prop_Associativity, prop_Identity,joinListAlgebra,JoinListMapFs(singleF)) where import GTA.Core @@ -10,20 +12,118 @@ import Control.DeepSeq -- join list = associative binary tree +{-| +Join lists. + +> x ++ y ==> x `Times` y +> [a] ==> Single a +> [] ==> Nil + +We assume that `Times` is associative and `Nil` is its identity: + +> x `Times` (y `Times` z) == (x `Times` y) `Times` z +> x `Times` Nil == Nil `Times` x == x + + -} data JoinList a = Times (JoinList a) (JoinList a) | Single a | Nil -- deriving (Show, Eq, Ord, Read) -- to use the GTA framework -genAllDecl ''JoinList +-- The following definitions can be generated automatically by @genAllDecl ''JoinList@ +-- They are written by hand here for writing comments. +-- algebra of JoinList +{-| +The algebra of join lists. + +We assume that `times` is associative and `nil` is its identity, inheriting those of `Times` and `Nil`: + +> x `times` (y `times` z) == (x `times` y) `times` z +> x `times` nil == nil `times` x == x + + +This can be generated automatically by @genAllDecl ''JoinList@. +-} +data JoinListAlgebra b a = JoinListAlgebra { + times :: a -> a -> a, + single :: b -> a, + nil :: a + } + +-- a set of functions for 'map' +{-| +A record to hold a function to be applied to elements of a list. + +This can be generated automatically by @genAllDecl ''JoinList@. +-} +data JoinListMapFs b b' = JoinListMapFs { + singleF :: b -> b' + } + +-- type parameters are algebra, free algebra, and functions for 'map' +{-| +Instance declaration of GTA.Data.GenericSemiringStructure for join lists. The implementation is quite straightforward. + +This can be generated automatically by @genAllDecl ''JoinList@. +-} +instance GenericSemiringStructure (JoinListAlgebra b) (JoinList b) (JoinListMapFs b) where + freeAlgebra = JoinListAlgebra {..} where + times = Times + single = Single + nil = Nil + pairAlgebra jla1 jla2 = JoinListAlgebra {..} where + times (l1, l2) (r1, r2) = (times1 l1 r1, times2 l2 r2) + single a = (single1 a, single2 a) + nil = (nil1, nil2) + (times1, single1, nil1) = let JoinListAlgebra {..} = jla1 in (times, single, nil) + (times2, single2, nil2) = let JoinListAlgebra {..} = jla2 in (times, single, nil) + makeAlgebra (CommutativeMonoid {..}) jla frec fsingle = JoinListAlgebra {..} where + times l r = foldr oplus identity [fsingle (times' l' r') | l' <- frec l, r' <- frec r] + single a = fsingle (single' a) + nil = fsingle nil' + (times', single', nil') = let JoinListAlgebra {..} = jla in (times, single, nil) + foldingAlgebra op iop (JoinListMapFs {..}) = JoinListAlgebra {..} where + times l r = l `op` r + single a = singleF a + nil = iop + hom (JoinListAlgebra {..}) = h where + h (Times l r) = times (h l) (h r) + h (Single a) = single a + h Nil = nil + +{-| A wrapper function for record 'JoinListAlgebra' . (I needed this as a workaround of cabal's brace-eating bug.)-} +joinListAlgebra :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a +joinListAlgebra times single nil = JoinListAlgebra{..} + +-- properties of JoinListAlgebra for correct parallelization +{-| Property of `times` of a JoinListAlgebra: + + > x `times` (y `times` z) == (x `times` y) `times` z + + -} +prop_Associativity :: (Eq b) => JoinListAlgebra a b -> (b,b,b) -> Bool +prop_Associativity (JoinListAlgebra{..}) (x,y,z) + = x `times` (y `times` z) == (x `times` y) `times` z + +{-| Property of `times` and `nil` of a JoinListAlgebra: + + > (x `times` nil == x) && (nil `times` x == x) + + -} +prop_Identity :: (Eq b) => JoinListAlgebra a b -> b -> Bool +prop_Identity (JoinListAlgebra{..}) x + = (x `times` nil == x) && (nil `times` x == x) + instance (NFData a) => (NFData (JoinList a)) where rnf (x `Times` y) = rnf x `seq` rnf y rnf (Single a) = rnf a rnf Nil = () -- stupid joinize function +{-| Conversion from a usual list to a join list. -} +-- This conversion is stupid. joinize :: forall a. [a] -> JoinList a joinize [] = Nil joinize [a] = Single a @@ -33,6 +133,8 @@ in Times (joinize x1) (joinize x2) -- stupid dejoinize function +{-| Conversion from a join list to a usual list. -} +-- This conversion is stupid. dejoinize :: forall a. JoinList a -> [a] dejoinize (Times x1 x2) = dejoinize x1 ++ dejoinize x2 dejoinize (Single a) = [a] @@ -53,18 +155,78 @@ -- renaming +{-| The usual semiring is a generic semiring of join lists: + +> a `times` (b `oplus` c) == (a `times` b) `oplus` (a `times` c) +> (a `oplus` b) `times` c == (a `times` c) `oplus` (b `times` c) +> a `times` identity == identity `times` a == identity + + -} type Semiring a s= GenericSemiring (JoinListAlgebra a) s +{-| This generates all segments (continuous subsequences) of a given list. + +For example, + +>>> segs [1,2,3] `aggregateBy` result +Bag [[1],[2],[3],[2,3],[1,2],[1,2,3],[]] + +-} segs :: [a] -> Semiring a s -> s segs = segsJ.joinize + +{-| This generates all prefixes of a given list. + +For example, + +>>> inits [1,2,3] `aggregateBy` result +Bag [[],[1],[1,2],[1,2,3]] + +-} inits :: [a] -> Semiring a s -> s inits = initsJ.joinize + +{-| This generates all suffixes of a given list. + +For example, + +>>> tails [1,2,3] `aggregateBy` result +Bag [[1,2,3],[2,3],[3],[]] + +-} tails :: [a] -> Semiring a s -> s tails = tailsJ.joinize + +{-| This generates all subsequences of a given list. + +For example, + +>>> subs [1,2,3] `aggregateBy` result +Bag [[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]] + +-} subs :: [a] -> Semiring a s -> s subs = subsJ.joinize + +{-| This generates all assignments of elements of the first list to elements of the second list. + +For example, + +>>> assigns [True,False] [1,2,3] `aggregateBy` result +Bag [[(True,1),(True,2),(True,3)],[(True,1),(True,2),(False,3)],[(True,1),(False,2),(True,3)],[(True,1),(False,2),(False,3)],[(False,1),(True,2),(True,3)],[(False,1),(True,2),(False,3)],[(False,1),(False,2),(True,3)],[(False,1),(False,2),(False,3)]] + +-} assigns :: [m] -> [a] -> Semiring (m, a) s -> s assigns ms = assignsJ ms.joinize + +{-| This is a generalization of `assigns`: the values to be assigned is dependent of the target. + +For example, + +>>> assignsBy (\a -> if odd a then [True, False] else [True]) [1,2,3] `aggregateBy` result +Bag [[(True,1),(True,2),(True,3)],[(True,1),(True,2),(False,3)],[(False,1),(True,2),(True,3)],[(False,1),(True,2),(False,3)]] + +-} assignsBy :: (a -> [m]) -> [a] -> Semiring (m, a) s -> s assignsBy f = assignsByJ f.joinize @@ -132,6 +294,14 @@ CommutativeMonoid {..} = monoid {- this generates lists from a tree, while CYK geenerates trees from a list -} +{-| This generates all paths from the root to leaves of a given binary tree. + +For example, + +>>> *Main GTA.Data.BinTree> paths (BinNode 1 (BinLeaf 2) (BinNode 3 (BinLeaf 4) (BinLeaf 5))) `aggregateBy` result +Bag [[1,2],[1,3,4],[1,3,5]] + +-} paths :: BinTree a a -> Semiring a s -> s paths x (GenericSemiring {..}) = paths' x where paths' (BinNode a l r) = single a `times` (paths' l `oplus` paths' r) @@ -140,64 +310,97 @@ CommutativeMonoid {..} = monoid -- useful function to map +{-| Wrapper for 'JoinListMapFs'. +-} mapJ :: forall b a. (b -> a) -> JoinListMapFs b a mapJ f = JoinListMapFs {..} where singleF = f -- JoinList-semiring for counting +{-| The aggregator to count the number of items in a generated bag. +-} count :: Num a => Semiring b a count = sumproductBy (JoinListMapFs {singleF = const 1}) {- simplified aggregators -} - +{-| The aggregator to take the maximum sum. +-} maxsum :: (Ord a, Num a) => Semiring a (AddIdentity a) maxsum = maxsumBy (JoinListMapFs {singleF = addIdentity}) +{-| The aggregator to find items with the maximum sum. +-} maxsumsolution :: (Ord a, Num a) => Semiring a (AddIdentity a, Bag (JoinList a)) maxsumsolution = maxsumsolutionBy (JoinListMapFs {singleF = addIdentity}) +{-| The aggregator to take the maximum sum after @map f@. +-} maxsumWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a) maxsumWith f = maxsumBy (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxsumWith`. +-} maxsumKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b ([AddIdentity a]) maxsumKWith k f = maxsumKBy k (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxsumsolutionXWith`. +-} maxsumsolutionXKWith :: (Ord a, Num a) => Semiring c b -> Int -> (c -> a) -> Semiring c [(AddIdentity a, b)] maxsumsolutionXKWith s k f = maxsumsolutionXKBy s k (mapJ (addIdentity.f)) +{-| The tupling of maxsumsolution and a given semiring. The second component is the aggregation of the maximum items by the given semiring. +-} maxsumsolutionXWith :: (Ord a, Num a) => Semiring c b -> (c -> a) -> Semiring c (AddIdentity a, b) maxsumsolutionXWith s f = maxsumsolutionXBy s (mapJ (addIdentity.f)) +{-| The aggregator to find items with the maximum sum after @map f@. +-} maxsumsolutionWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a, Bag (JoinList b)) maxsumsolutionWith f = maxsumsolutionBy (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxsumsolutionWith`. +-} maxsumsolutionKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b [(AddIdentity a, Bag (JoinList b))] maxsumsolutionKWith k f = maxsumsolutionKBy k (mapJ (addIdentity.f)) +{-| The aggregator to take the maximum product of /non-negative/ numbers after @map f@. +-} maxprodWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a) maxprodWith f = maxprodBy (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxprodWith`. +-} maxprodKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b ([AddIdentity a]) maxprodKWith k f = maxprodKBy k (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxprodsolutionXWith`. +-} maxprodsolutionXKWith :: (Ord a, Num a) => Semiring c b -> Int -> (c -> a) -> Semiring c [(AddIdentity a, b)] maxprodsolutionXKWith s k f = maxprodsolutionXKBy s k (mapJ (addIdentity.f)) + +{-| The tupling of maxprodsolution and a given semiring. The second component is the aggregation of the maximum items by the given semiring. +-} maxprodsolutionXWith :: (Ord a, Num a) => Semiring c b -> (c -> a) -> Semiring c (AddIdentity a, b) maxprodsolutionXWith s f = maxprodsolutionXBy s (mapJ (addIdentity.f)) +{-| The aggregator to find items with the maximum product. The numbers have to be /non-negative/. +-} maxprodsolutionWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a, Bag (JoinList b)) maxprodsolutionWith f = maxprodsolutionBy (mapJ (addIdentity.f)) +{-| The /best-k/ extension of `maxprodsolutionWith`. +-} maxprodsolutionKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b [(AddIdentity a, Bag (JoinList b))] maxprodsolutionKWith k f = maxprodsolutionKBy k (mapJ (addIdentity.f)) --- parallel generators +{-| Parallel version of `segs`. -} segsP :: (NFData s) => [a] -> Semiring a s -> s segsP = segsJP.joinize @@ -216,6 +419,7 @@ CommutativeMonoid {..} = monoid +{-| Parallel version of `inits`. -} initsP :: (NFData s) => [a] -> Semiring a s -> s initsP = initsJP.joinize @@ -233,6 +437,7 @@ JoinListAlgebra {..} = algebra CommutativeMonoid {..} = monoid +{-| Parallel version of `tails`. -} tailsP :: (NFData s) => [a] -> Semiring a s -> s tailsP = tailsJP.joinize @@ -250,6 +455,7 @@ JoinListAlgebra {..} = algebra CommutativeMonoid {..} = monoid +{-| Parallel version of `subs`. -} subsP :: (NFData s) => [a] -> Semiring a s -> s subsP = subsJP.joinize @@ -260,6 +466,7 @@ JoinListAlgebra {..} = algebra CommutativeMonoid {..} = monoid +{-| Parallel version of `assigns`. -} assignsP :: (NFData s) => [m] -> [a] -> Semiring (m, a) s -> s assignsP ms = assignsJP ms.joinize assignsJP :: (NFData s) => [m] -> JoinList a -> Semiring (m,a) s -> s @@ -269,6 +476,7 @@ JoinListAlgebra {..} = algebra CommutativeMonoid {..} = monoid +{-| Parallel version of `assignsBy`. -} assignsByP :: (NFData s) => (a -> [m]) -> [a] -> Semiring (m, a) s -> s assignsByP f = assignsByJP f.joinize assignsByJP :: (NFData s) => (a -> [m]) -> JoinList a -> Semiring (m,a) s -> s @@ -289,19 +497,59 @@ h _ Nil = nil --- useful functions to design generators: constructors of bags of lists +{-| Constructor of a bag of join lists. + +For example, + +>>> (bag (map joinize [[1,2], [3]])) `crossConcat` (bag (map joinize [[4,5], [6]])) +Bag [[1,2,4,5],[1,2,6],[3,4,5],[3,6]] + + -} crossConcat :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a) crossConcat = times (algebra freeSemiring) +{-| Constructor of a bag of join lists. + +For example, + +>>> bagOfSingleton 1 +Bag [[1]] + + -} bagOfSingleton :: a -> Bag (JoinList a) bagOfSingleton = single (algebra freeSemiring) +{-| Constructor of a bag of join lists. + +For example, + +>>> bagOfNil +Bag [[]] + +-} bagOfNil :: Bag (JoinList a) bagOfNil = nil (algebra freeSemiring) +{-| Constructor of a bag of join lists. + +For example, + +>>> emptyBag +Bag [] + +-} emptyBag :: Bag (JoinList a) emptyBag = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a)) in identity monoid +{-| Constructor of a bag of join lists. + +For example, + +>>> (bag (map joinize [[1,2], [3]])) `bagUnion` (bag (map joinize [[4,5], [6]])) +Bag [[1,2],[3],[4,5],[6]] + + -} bagUnion :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a) bagUnion = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a)) in oplus monoid
src/GTA/Util/GenericSemiringStructureTemplate.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,TemplateHaskell #-} +{-| This module provides a mechanism for automatic generation of data-structure-dependent definitions necessary for the GTA framework (namely, an instance of 'GTA.Core.GenericSemiringStructure' as well as definitions of algebras and structures for map functions). +-} module GTA.Util.GenericSemiringStructureTemplate (genAlgebraDecl, genMapFunctionsDecl, genInstanceDecl, genAllDecl) where import Language.Haskell.TH@@ -11,24 +13,81 @@ -} {- exported functions -}+{-| This function generates a definition of the algebra of a given data structure. For example, given a data structure defined below,++> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)+> | BinLeaf l++the following definition of the algebra is generated by @genAlgebraDecl ''BinTree@.++> data BinTreeAlgebra n l a = BinTreeAlgebra {+> binNode :: n -> a -> a -> a,+> binLeaf :: l -> a+> }++-} genAlgebraDecl :: Name -> Q [Dec] genAlgebraDecl typName = do (typeName,typeParams,constructors) <- typeInfo typName alg <- genAlgebraRecord typeName typeParams constructors return ([alg]) +{-| This function generates a definition of a record holding functions to be mapped to values in a given data structure. For example, given a data structure defined below,++> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)+> | BinLeaf l+ +the following record is generated by @genMapFunctionsDecl ''BinTree@.++> data BinTreeMapFs n l b' = BinTreeMapFs {+> binNodeF :: n -> b',+> binLeafF :: l -> b'+> }+ +-} genMapFunctionsDecl :: Name -> Q [Dec] genMapFunctionsDecl typName = do (typeName,typeParams,constructors) <- typeInfo typName alg <- genMapFunctionsRecord typeName typeParams constructors return ([alg]) +{-| This function generates an instance of 'GTA.Data.GenericSemiringStructure' for a given data structure. For example, given a data structure defined below,++> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)+> | BinLeaf l+ +the following record is generated by @genInstanceDecl''BinTree@.++> instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where+> freeAlgebra = BinTreeAlgebra {..} where+> binNode = BinNode+> binLeaf = BinLeaf+> pairAlgebra lvta1 lvta2 = BinTreeAlgebra {..} where+> binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2)+> binLeaf a = (binLeaf1 a, binLeaf2 a)+> (binNode1, binLeaf1) = let BinTreeAlgebra {..} = lvta1 in (binNode, binLeaf)+> (binNode2, binLeaf2) = let BinTreeAlgebra {..} = lvta2 in (binNode, binLeaf)+> makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = BinTreeAlgebra {..} where +> binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r]+> binLeaf a = fsingle (binLeaf' a)+> (binNode', binLeaf') = let BinTreeAlgebra {..} = lvta in (binNode, binLeaf)+> foldingAlgebra op iop (BinTreeMapFs {..}) = BinTreeAlgebra {..} where+> binNode a l r = binNodeF a `op` l `op` r+> binLeaf a = binLeafF a+> hom (BinTreeAlgebra {..}) = h where+> h (BinNode a l r) = binNode a (h l) (h r)+> h (BinLeaf a) = binLeaf a+> ++-} genInstanceDecl :: Name -> Q [Dec] genInstanceDecl typName = do (typeName,typeParams,constructors) <- typeInfo typName inst <- genSemiringInstance typeName typeParams constructors return ([inst]) +{-| Given a data structure, this function generates a definition of its algebra (by @genAlgebraDecl@), a record of map functions (by @genMapFunctionsDecl@), and an instance of 'GTA.Data.GenericSemiringStructure' (by @genInstanceDecl@). Usage: @genAllDecl ''BinTree@.+-} genAllDecl :: Name -> Q [Dec] genAllDecl typName = do alg <- genAlgebraDecl typName@@ -88,7 +147,7 @@ mkTupleType [a] = a mkTupleType x = foldl appT (tupleT (length x)) x {-- instance GenericSemiringStructure (BTreeAlgebra b) (BTree b) (BTreeMapFunctions b) where+ instance GenericSemiringStructure (BTreeAlgebra b) (BTree b) (BTreeMapFs b) where -} genSemiringInstance :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ genSemiringInstance typeName typeParams constructors = @@ -179,10 +238,10 @@ in genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody {-- foldingAlgebra op (BTreeMapFs {nodeF=(nodeF1),leafMF=(leafF1)}) = BTreeAlgebra {..}+ foldingAlgebra op iop (BTreeMapFs {..}) = BTreeAlgebra {..} where- node a l r = nodeF1 a `op` l `op` r- leaf a = leafF1 a+ node a l r = nodeF a `op` l `op` r+ leaf a = leafF a -} genFoldingAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ genFoldingAlgebra typeName typeParams constructors = @@ -250,7 +309,7 @@ {- TODO: this function has been split into several parts. write comments! -e.g., to generate the following,+e.g., to generate the following (obsolete, though), liftedAlgebra bts bt = BTreeAlgebra {..} where
src/GTA/Util/TypeInfo.hs view
@@ -1,14 +1,12 @@ {- -copied from: - http://haskell.1045720.n5.nabble.com/Deriving-Read-with-Template-Haskell-Re-automatic-instances-for-pretty-printing-and-parsing-td3197647.html -modified.- -} {-|+ Copied from <http://haskell.1045720.n5.nabble.com/Deriving-Read-with-Template-Haskell-Re-automatic-instances-for-pretty-printing-and-parsing-td3197647.html>, and modified a bit.+ Observing a structure of a datatype in a uniform way no matter whether it was defined in infix, prefix or record form. @@ -29,6 +27,9 @@ --type TypeInfo = (Name, [Name], [(Name, [(Maybe Name, Type)])]) type TypeInfo = (Name, [TyVarBndr], [(Name, [(Maybe Name, Type)])]) +{-|+ Returns type information of a given type.+-} typeInfo :: Name -> Q TypeInfo typeInfo name = do info' <- reify name