GTALib 0.0.5 → 0.0.6
raw patch · 8 files changed
+1258/−1160 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- GTA.Data.JoinList: joinListAlgebra :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a
+ GTA.Core: instance [overlap ok] NFData a => NFData (RevOrd a)
+ GTA.Data.ConsList: mapMap :: (b -> b') -> GenericSemiring (ConsListAlgebra b') a -> GenericSemiring (ConsListAlgebra b) a
+ GTA.Data.ConsList: perms :: [a] -> ConsSemiring a s -> s
+ GTA.Data.JoinList: homJ :: (a -> a -> a) -> (b -> a) -> a -> JoinList b -> a
+ GTA.Data.JoinList: homJ' :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a
+ GTA.Data.JoinList: mapMap :: (b -> b') -> GenericSemiring (JoinListAlgebra b') a -> GenericSemiring (JoinListAlgebra b) a
+ GTA.Data.JoinList: perms :: [a] -> Semiring a s -> s
+ GTA.Data.JoinList: permsP :: NFData s => [a] -> Semiring a s -> s
Files
- GTALib.cabal +2/−2
- src/GTA/Core.hs +541/−511
- src/GTA/Data/BinTree.hs +3/−2
- src/GTA/Data/ConsList.hs +19/−3
- src/GTA/Data/JoinList.hs +606/−557
- src/GTA/Util/GenericSemiringStructureTemplate.hs +59/−59
- src/GTA/Util/TypeInfo.hs +21/−26
- test/test.hs +7/−0
GTALib.cabal view
@@ -7,7 +7,7 @@ -- 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.5 +Version: 0.0.6 -- A short (one-line) description of the package. Synopsis: A library for GTA programming @@ -29,7 +29,7 @@ > getWeight (w, _) = w > > weightlimit w = (<=w) <.> weightsum where - > weightsum = joinListAlgebra times single nil --workaround for cabal's brace-eating bug + > weightsum = homJ' times single nil > x1 `times` x2 = ( x1 + x2) `min` (w+1) > single i = getWeight i `min` (w+1) > nil = 0
src/GTA/Core.hs view
@@ -1,511 +1,541 @@-{-# 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/ - - 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 - rnf (Bag x) = rnf x - -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 - ---Bag filter -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 { - {-| 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 -bagMonoid :: forall a. CommutativeMonoid (Bag a) -bagMonoid = CommutativeMonoid { .. } where - oplus (Bag a) (Bag b) = Bag (a ++ b) - identity = Bag [] - --- finite map is commutative monoid -mapMonoid :: forall k a. Ord k => CommutativeMonoid a -> CommutativeMonoid (Map k a) -mapMonoid m = CommutativeMonoid { .. } where - oplus x y = let CommutativeMonoid {..} = m in unionWith oplus x y - identity = empty - ---singleton bag -singletonBag :: forall a. a -> Bag a -singletonBag b = Bag [b] - ---tupled monoid -pairMonoid :: forall t t1.CommutativeMonoid t -> CommutativeMonoid t1 -> CommutativeMonoid (t, t1) -pairMonoid m1 m2 = CommutativeMonoid {..} where - identity = (identity1, identity2) - oplus (l1, l2) (r1, r2) = (oplus1 l1 r1, oplus2 l2 r2) - (oplus1, identity1) = let CommutativeMonoid {..} = m1 in (oplus, identity) - (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. -} - freeSemiring = GenericSemiring {..} - where - monoid = bagMonoid - algebra = makeAlgebra bagMonoid freeAlgebra items singletonBag - liftedSemiring s a = GenericSemiring {monoid=monoid', algebra=algebra'} - where - monoid' = let GenericSemiring {..} = s in mapMonoid monoid - algebra' = makeAlgebra (mapMonoid (monoid s)) (pairAlgebra a (algebra s)) assocs (uncurry singleton) - shom (GenericSemiring {..}) = sh - where - CommutativeMonoid {..} = monoid - sh (Bag b) = foldr oplus identity (map (hom algebra) b) - pairSemiring s1 s2 = GenericSemiring {monoid=monoid', algebra=algebra'} - where - monoid' = pairMonoid (monoid s1) (monoid s2) - algebra' = pairAlgebra (algebra s1) (algebra s2) - - - --- 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) => - (GenericSemiring alg (Map c b) -> Map k b) - -> (k -> Bool, alg c) - -> GenericSemiring alg b - -> b -(>==) pgen (ok, bt) bts = - let res = pgen (liftedSemiring bts bt) - CommutativeMonoid {..} = monoid bts - 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) => - (GenericSemiring alg b -> b) -> GenericSemiring alg b -> b -(>=>) 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' :: * -> *) - c. - (GenericSemiringStructure alg free uniformer, - GenericSemiringStructure alg' free' uniformer') => - (GenericSemiring alg' c -> c) -> - (GenericSemiring alg c -> GenericSemiring alg' c) -> - GenericSemiring alg c -> c -(>=<) 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) - -> (k -> Bool, alg c) - -> GenericSemiring alg b - -> 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. - (GenericSemiringStructure alg free uniformer, - GenericSemiringStructure alg' free' uniformer') => - (GenericSemiring alg' c -> c) -> - (GenericSemiring alg c -> GenericSemiring alg' c) -> - GenericSemiring alg c -> c -transformBy = (>=<) - - - --- 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) - -> (b -> Bool, alg b) -> GenericSemiring alg (Bag free) -> Bag free -(>##) pgen (ok, bt) _ = filterB (ok.hom bt) bag - 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) - -> GenericSemiring alg a -> a -(>#>) pgen bts = shom bts (pgen freeSemiring) - - --- 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 (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) -result = freeSemiring - - --- aggregator based on the usual semirings -genAlgebraFromSemiring :: forall free (uniformer :: * -> *) (alg :: * -> *) a. - GenericSemiringStructure alg free uniformer => - (a -> a -> a) - -> a - -> (a -> a -> a) - -> a - -> uniformer a - -> GenericSemiring alg a -genAlgebraFromSemiring op iop ot iot mf = GenericSemiring {..} where - monoid = CommutativeMonoid {..} where - oplus a b = a `op` b - 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 - compare Identity (AddIdentity _) = LT - compare (AddIdentity _) Identity = GT - compare (AddIdentity a) (AddIdentity b) = compare a b - -instance (NFData a) => (NFData (AddIdentity a)) where - 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) - -> a - -> uniformer (AddIdentity a) - -> GenericSemiring alg (AddIdentity a) -maxMonoSumBy mplus mid mf = genAlgebraFromSemiring max Identity plus (AddIdentity mid) mf - where plus Identity _ = Identity - plus _ Identity = Identity - 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) - -> a - -> GenericSemiring alg t - -> uniformer (AddIdentity a) - -> GenericSemiring alg (AddIdentity a, t) -maxMonoSumsolutionXBy mplus mid s mf = GenericSemiring {..} where - monoid = CommutativeMonoid {..} where - oplus (a, x) (b, y) - = case compare a b of - EQ -> (a, x `oplus'` y) - LT -> (b, y) - GT -> (a, x) - identity = (Identity, identity') - algebra = pairAlgebra maxMonoSumAlgebra algebra' - maxMonoSumAlgebra = let GenericSemiring {..} = maxMonoSumBy mplus mid mf in algebra - (monoid', algebra') = let GenericSemiring {..} = s in (monoid, algebra) - (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) - -> a - -> Int - -> uniformer (AddIdentity a) - -> GenericSemiring alg [AddIdentity a] -maxMonoSumKBy mplus mid k mf = GenericSemiring {..} where - monoid = CommutativeMonoid {..} where - oplus x y = take k (map head (group (reverse (sort (x ++ y))))) - identity = [] - algebra = makeAlgebra monoid maxMonoSumAlgebra id sing - sing a = [a] - 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) - -> a - -> GenericSemiring alg b - -> Int - -> uniformer (AddIdentity a) - -> GenericSemiring alg [(AddIdentity a, b)] -maxMonoSumsolutionXKBy mplus mid s k mf = GenericSemiring {..} where - monoid = CommutativeMonoid {..} where - oplus x y = - let std = reverse (sortBy fstCmp (x ++ y)) - grpd = groupBy (\a b -> fstCmp a b == EQ) std - fstCmp a b = compare (fst a) (fst b) - op (a, x) (_, y) = (a, x `oplus'` y) - in take k (map (foldr1 op) grpd) - identity = [] - (oplus', identity') = let CommutativeMonoid {..} = monoid' in (oplus, identity) - algebra = makeAlgebra monoid (pairAlgebra maxMonoSumAlgebra algebra') id sing - sing a = [a] - maxMonoSumAlgebra = let GenericSemiring {..} = maxMonoSumBy mplus mid mf in algebra - (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 - -> uniformer (AddIdentity a) - -> 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 - -> Int - -> uniformer (AddIdentity a) - -> 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 - -> uniformer (AddIdentity a) - -> GenericSemiring alg (AddIdentity a, t) -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) - -> GenericSemiring alg (AddIdentity a, Bag free) -maxsumsolutionBy = maxsumsolutionXBy freeSemiring - - -{-| The /best-k/ extension of `maxsumsolutionBy`. --} -maxsumsolutionKBy :: forall a (alg :: * -> *) free (uniformer :: * -> *). - (GenericSemiringStructure alg free uniformer, Ord a, Num a) => - Int - -> uniformer (AddIdentity a) - -> GenericSemiring alg [(AddIdentity a, Bag free)] -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 - -> uniformer (AddIdentity a) - -> GenericSemiring alg [AddIdentity a] -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 - -> Int - -> uniformer (AddIdentity a) - -> 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 - -> uniformer (AddIdentity a) - -> 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 - -> uniformer (AddIdentity a) - -> GenericSemiring alg [(AddIdentity a, Bag free)] -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) - -instance (Num a) => (Num (RevOrd a)) where - (+) (RevOrd a) (RevOrd b) = RevOrd (a + b) - (*) (RevOrd a) (RevOrd b) = RevOrd (a * b) - (-) (RevOrd a) (RevOrd b) = RevOrd (a - b) - negate (RevOrd a) = RevOrd (negate a) - abs (RevOrd a) = RevOrd (abs a) - signum (RevOrd a) = RevOrd (signum a) - fromInteger a = RevOrd (fromInteger a) - - -instance (Ord a) => (Ord (RevOrd a)) where - compare (RevOrd a) (RevOrd b) = - case compare a b of - EQ -> EQ - LT -> GT - GT -> LT - - - - - +{-# 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/+-- +-- 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 = homJ' times single nil+-- > 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+ rnf (Bag x) = rnf x++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++--Bag filter+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 {+-- | 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+bagMonoid :: forall a. CommutativeMonoid (Bag a)+bagMonoid = CommutativeMonoid { .. } where + oplus (Bag a) (Bag b) = Bag (a ++ b)+ identity = Bag []++-- finite map is commutative monoid+mapMonoid :: forall k a. Ord k => CommutativeMonoid a -> CommutativeMonoid (Map k a)+mapMonoid m = CommutativeMonoid { .. } where+ oplus x y = let CommutativeMonoid {..} = m in unionWith oplus x y+ identity = empty++--singleton bag+singletonBag :: forall a. a -> Bag a+singletonBag b = Bag [b]++--tupled monoid+pairMonoid :: forall t t1.CommutativeMonoid t -> CommutativeMonoid t1 -> CommutativeMonoid (t, t1)+pairMonoid m1 m2 = CommutativeMonoid {..} where+ identity = (identity1, identity2)+ oplus (l1, l2) (r1, r2) = (oplus1 l1 r1, oplus2 l2 r2) + (oplus1, identity1) = let CommutativeMonoid {..} = m1 in (oplus, identity)+ (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. -}+ freeSemiring = GenericSemiring {..}+ where+ monoid = bagMonoid+ algebra = makeAlgebra bagMonoid freeAlgebra items singletonBag+ liftedSemiring s a = GenericSemiring {monoid=monoid', algebra=algebra'}+ where+ monoid' = let GenericSemiring {..} = s in mapMonoid monoid+ algebra' = makeAlgebra (mapMonoid (monoid s)) (pairAlgebra a (algebra s)) assocs (uncurry singleton)+ shom (GenericSemiring {..}) = sh+ where + CommutativeMonoid {..} = monoid+ sh (Bag b) = foldr oplus identity (map (hom algebra) b)+ pairSemiring s1 s2 = GenericSemiring {monoid=monoid', algebra=algebra'} + where + monoid' = pairMonoid (monoid s1) (monoid s2)+ algebra' = pairAlgebra (algebra s1) (algebra s2)++++-- 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) =>+ (GenericSemiring alg (Map c b) -> Map k b)+ -> (k -> Bool, alg c)+ -> GenericSemiring alg b+ -> b+(>==) pgen (ok, bt) bts = + let res = pgen (liftedSemiring bts bt)+ CommutativeMonoid {..} = monoid bts+ 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) =>+ (GenericSemiring alg b -> b) -> GenericSemiring alg b -> b+(>=>) 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' :: * -> *)+ c.+ (GenericSemiringStructure alg free uniformer,+ GenericSemiringStructure alg' free' uniformer') =>+ (GenericSemiring alg' c -> c) -> + (GenericSemiring alg c -> GenericSemiring alg' c) -> + GenericSemiring alg c -> c+(>=<) 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)+ -> (k -> Bool, alg c)+ -> GenericSemiring alg b+ -> 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.+ (GenericSemiringStructure alg free uniformer,+ GenericSemiringStructure alg' free' uniformer') =>+ (GenericSemiring alg' c -> c) -> + (GenericSemiring alg c -> GenericSemiring alg' c) -> + GenericSemiring alg c -> c+transformBy = (>=<)++++-- 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)+ -> (b -> Bool, alg b) -> GenericSemiring alg (Bag free) -> Bag free+(>##) pgen (ok, bt) _ = filterB (ok.hom bt) bag+ 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)+ -> GenericSemiring alg a -> a+(>#>) pgen bts = shom bts (pgen freeSemiring)+++-- 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 (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)+result = freeSemiring+++-- aggregator based on the usual semirings+genAlgebraFromSemiring :: forall free (uniformer :: * -> *) (alg :: * -> *) a.+ GenericSemiringStructure alg free uniformer =>+ (a -> a -> a)+ -> a+ -> (a -> a -> a)+ -> a+ -> uniformer a+ -> GenericSemiring alg a+genAlgebraFromSemiring op iop ot iot mf = GenericSemiring {..} where+ monoid = CommutativeMonoid {..} where+ oplus a b = a `op` b+ 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+ compare Identity (AddIdentity _) = LT+ compare (AddIdentity _) Identity = GT+ compare (AddIdentity a) (AddIdentity b) = compare a b++instance (NFData a) => (NFData (AddIdentity a)) where+ 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)+ -> a+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg (AddIdentity a)+maxMonoSumBy mplus mid mf = genAlgebraFromSemiring max Identity plus (AddIdentity mid) mf+ where plus Identity _ = Identity+ plus _ Identity = Identity+ 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)+ -> a+ -> GenericSemiring alg t+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg (AddIdentity a, t)+maxMonoSumsolutionXBy mplus mid s mf = GenericSemiring {..} where+ monoid = CommutativeMonoid {..} where+ oplus (a, x) (b, y) + = case compare a b of+ EQ -> (a, x `oplus'` y)+ LT -> (b, y)+ GT -> (a, x)+ identity = (Identity, identity')+ algebra = pairAlgebra maxMonoSumAlgebra algebra'+ maxMonoSumAlgebra = let GenericSemiring {..} = maxMonoSumBy mplus mid mf in algebra+ (monoid', algebra') = let GenericSemiring {..} = s in (monoid, algebra)+ (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)+ -> a+ -> Int+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg [AddIdentity a]+maxMonoSumKBy mplus mid k mf = GenericSemiring {..} where+ monoid = CommutativeMonoid {..} where+ oplus x y = take k (map head (group (reverse (sort (x ++ y)))))+ identity = []+ algebra = makeAlgebra monoid maxMonoSumAlgebra id sing+ sing a = [a]+ 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)+ -> a+ -> GenericSemiring alg b+ -> Int+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg [(AddIdentity a, b)]+maxMonoSumsolutionXKBy mplus mid s k mf = GenericSemiring {..} where+ monoid = CommutativeMonoid {..} where+ oplus x y = + let std = reverse (sortBy fstCmp (x ++ y))+ grpd = groupBy (\a b -> fstCmp a b == EQ) std+ fstCmp a b = compare (fst a) (fst b)+ op (a, x) (_, y) = (a, x `oplus'` y)+ in take k (map (foldr1 op) grpd)+ identity = []+ (oplus', identity') = let CommutativeMonoid {..} = monoid' in (oplus, identity)+ algebra = makeAlgebra monoid (pairAlgebra maxMonoSumAlgebra algebra') id sing+ sing a = [a]+ maxMonoSumAlgebra = let GenericSemiring {..} = maxMonoSumBy mplus mid mf in algebra+ (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+ -> uniformer (AddIdentity a)+ -> 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+ -> Int+ -> uniformer (AddIdentity a)+ -> 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+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg (AddIdentity a, t)+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)+ -> GenericSemiring alg (AddIdentity a, Bag free)+maxsumsolutionBy = maxsumsolutionXBy freeSemiring+++-- | The /best-k/ extension of `maxsumsolutionBy`.+-- +maxsumsolutionKBy :: forall a (alg :: * -> *) free (uniformer :: * -> *).+ (GenericSemiringStructure alg free uniformer, Ord a, Num a) =>+ Int+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg [(AddIdentity a, Bag free)]+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+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg [AddIdentity a]+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+ -> Int+ -> uniformer (AddIdentity a)+ -> 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+ -> uniformer (AddIdentity a)+ -> 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+ -> uniformer (AddIdentity a)+ -> GenericSemiring alg [(AddIdentity a, Bag free)]+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)++instance (Num a) => (Num (RevOrd a)) where+ (+) (RevOrd a) (RevOrd b) = RevOrd (a + b)+ (*) (RevOrd a) (RevOrd b) = RevOrd (a * b) + (-) (RevOrd a) (RevOrd b) = RevOrd (a - b)+ negate (RevOrd a) = RevOrd (negate a)+ abs (RevOrd a) = RevOrd (abs a)+ signum (RevOrd a) = RevOrd (signum a)+ fromInteger a = RevOrd (fromInteger a)+ ++instance (Ord a) => (Ord (RevOrd a)) where+ compare (RevOrd a) (RevOrd b) = + case compare a b of + EQ -> EQ+ LT -> GT+ GT -> LT++instance (NFData a) => (NFData (RevOrd a)) where+ rnf (RevOrd a) = rnf a++++
src/GTA/Data/BinTree.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell,TypeSynonymInstances #-} -{-| 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. --} +-- | 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
src/GTA/Data/ConsList.hs view
@@ -5,14 +5,16 @@ (we can make a concise, specialized GTA framework for cons-lists, but...) -} -{-| 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 +-- | 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),mapMap,perms) where import GTA.Core import GTA.Util.GenericSemiringStructureTemplate import GTA.Data.BinTree (BinTree (..)) +import qualified Data.IntSet as IntSet -- cons list = the usual list in FP @@ -129,6 +131,15 @@ ConsListAlgebra {..} = algebra CommutativeMonoid {..} = monoid +perms :: [a] -> ConsSemiring a s -> s +perms x = assigns (zip [1..n] x) [1..n] `transformBy` mapMap fst `filterBy` spans n `transformBy` mapMap snd + where n = length x + +spans n = ok <.> foldr' f e where + e = IntSet.empty + f (v,_) x = IntSet.insert v x + ok x = IntSet.size x == n + {- this generates lists from a tree, while CYK geenerates trees from a list -} paths :: BinTree a a -> ConsSemiring a s -> s paths x (GenericSemiring {..}) = paths' x @@ -211,3 +222,8 @@ in oplus monoid +mapMap :: (b -> b') -> GenericSemiring (ConsListAlgebra b') a -> GenericSemiring (ConsListAlgebra b) a +mapMap f (GenericSemiring {..}) = + GenericSemiring {algebra=algebra',monoid=monoid} where + ConsListAlgebra{..} = algebra + algebra' = ConsListAlgebra{cons=cons.f,nil=nil}
src/GTA/Data/JoinList.hs view
@@ -1,557 +1,606 @@-{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell #-} - -{-| 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 -import GTA.Util.GenericSemiringStructureTemplate -import GTA.Data.BinTree (BinTree (..)) -import Control.Parallel -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 --- 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 -joinize x = let (x1,x2) = splitAt d x - n = length x - d = (n `div` 2) - 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] -dejoinize (Nil) = [] - -instance Show a => Show (JoinList a) where - showsPrec d x = showsPrec d (dejoinize x) - -instance Read a => Read (JoinList a) where - readsPrec d x = map (\(y, s)->(joinize y, s)) (readsPrec d x) - -instance Eq a => Eq (JoinList a) where - (==) x y = dejoinize x == dejoinize y - -instance Ord a => Ord (JoinList a) where - compare x y = compare (dejoinize x) (dejoinize y) - - - --- 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 - -segsJ :: JoinList a -> Semiring a s -> s -segsJ x (GenericSemiring {..}) = - let (s, _, _, _) = segs' x - in s `oplus` nil - where segs' = hom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (s1, i1, t1, a1) = x1 - (s2, i2, t2, a2) = x2 - in ((s1 `oplus` s2) `oplus` (t1 `times` i2), i1 `oplus` (a1 `times` i2), (t1 `times` a2) `oplus`t2, a1 `times` a2) - single' a = let sa = single a in (sa, sa, sa, sa) - nil' = (identity, identity, identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -initsJ :: JoinList a -> Semiring a s -> s -initsJ x (GenericSemiring {..}) = - let (i, _) = inits' x - in nil `oplus` i - where inits' = hom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (i1, a1) = x1 - (i2, a2) = x2 - in (i1 `oplus` (a1 `times` i2), a1 `times` a2) - single' a = let sa = single a in (sa, sa) - nil' = (identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -tailsJ :: JoinList a -> Semiring a s -> s -tailsJ x (GenericSemiring {..}) = - let (t, _) = tails' x - in t `oplus` nil - where tails' = hom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (t1, a1) = x1 - (t2, a2) = x2 - in ((t1 `times` a2) `oplus`t2, a1 `times` a2) - single' a = let sa = single a in (sa, sa) - nil' = (identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -subsJ :: JoinList a -> Semiring a s -> s -subsJ x (GenericSemiring {..}) = subs' x - where subs' = hom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = single a `oplus` nil - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -assignsJ :: [m] -> JoinList a -> Semiring (m,a) s -> s -assignsJ ms x (GenericSemiring {..}) = assigns' x - where assigns' = hom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = foldr oplus identity [single (m, a) | m <- ms] - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -assignsByJ :: (a -> [m]) -> JoinList a -> Semiring (m,a) s -> s -assignsByJ f x (GenericSemiring {..}) = assigns' x - where assigns' = hom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = foldr oplus identity [single (m, a) | m <- f a] - JoinListAlgebra {..} = algebra - 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) - paths' (BinLeaf a) = single a - JoinListAlgebra {..} = algebra - 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 - -segsJP :: (NFData s) => JoinList a -> Semiring a s -> s -segsJP x (GenericSemiring {..}) = - let (s, _, _, _) = segs' x - in s `oplus` nil - where segs' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (s1, i1, t1, a1) = x1 - (s2, i2, t2, a2) = x2 - in ((s1 `oplus` s2) `oplus` (t1 `times` i2), i1 `oplus` (a1 `times` i2), (t1 `times` a2) `oplus`t2, a1 `times` a2) - single' a = let sa = single a in (sa, sa, sa, sa) - nil' = (identity, identity, identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - - -{-| Parallel version of `inits`. -} -initsP :: (NFData s) => [a] -> Semiring a s -> s -initsP = initsJP.joinize - -initsJP :: (NFData s) => JoinList a -> Semiring a s -> s -initsJP x (GenericSemiring {..}) = - let (i, _) = inits' x - in nil `oplus` i - where inits' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (i1, a1) = x1 - (i2, a2) = x2 - in (i1 `oplus` (a1 `times` i2), a1 `times` a2) - single' a = let sa = single a in (sa, sa) - nil' = (identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -{-| Parallel version of `tails`. -} -tailsP :: (NFData s) => [a] -> Semiring a s -> s -tailsP = tailsJP.joinize - -tailsJP :: (NFData s) => JoinList a -> Semiring a s -> s -tailsJP x (GenericSemiring {..}) = - let (t, _) = tails' x - in t `oplus` nil - where tails' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'}) - times' x1 x2 = - let (t1, a1) = x1 - (t2, a2) = x2 - in ((t1 `times` a2) `oplus`t2, a1 `times` a2) - single' a = let sa = single a in (sa, sa) - nil' = (identity, nil) - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - -{-| Parallel version of `subs`. -} -subsP :: (NFData s) => [a] -> Semiring a s -> s -subsP = subsJP.joinize - -subsJP :: (NFData s) => JoinList a -> Semiring a s -> s -subsJP x (GenericSemiring {..}) = subs' x - where subs' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = single a `oplus` nil - 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 -assignsJP ms x (GenericSemiring {..}) = assigns' x - where assigns' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = foldr oplus identity [single (m, a) | m <- ms] - 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 -assignsByJP f x (GenericSemiring {..}) = assigns' x - where assigns' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil}) - single' a = foldr oplus identity [single (m, a) | m <- f a] - JoinListAlgebra {..} = algebra - CommutativeMonoid {..} = monoid - - - -parallelJoinListHom :: forall t a. (NFData a) => JoinListAlgebra t a -> JoinList t -> a -parallelJoinListHom (JoinListAlgebra {..}) = h (6::Int) --at most 64 parallel - where h n (x1 `Times` x2) = if n > 0 then p1 `par` (p2 `pseq` (p1 `times` p2)) else p1 `times` p2 - where p1 = h (n-1) x1 - p2 = h (n-1) x2 - h _ (Single a) = single a - 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 - - +{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell #-}++-- | 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,JoinListMapFs(singleF),homJ, homJ',mapMap, perms, permsP) where+++import GTA.Core+import GTA.Util.GenericSemiringStructureTemplate+import GTA.Data.BinTree (BinTree (..))+import Control.Parallel+import Control.DeepSeq+import qualified Data.IntSet as IntSet+ +-- 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+-- 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 JoinList homomorphism. +-- +homJ :: (a -> a -> a) -> (b -> a) -> a -> JoinList b -> a+homJ times single nil = hom $ JoinListAlgebra{..}++-- | A fake function of homJ to build 'JoinListAlgebra' instead of executing the homomorphism with it. +-- +homJ' :: (a -> a -> a) -> (b -> a) -> a -> JoinListAlgebra b a+homJ' 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 = ()+++evenDivideDepth :: Int+evenDivideDepth = 6 --at most 64 parallel++-- | Conversion from a usual list to a join list. +-- +joinize :: forall a. [a] -> JoinList a+joinize x = joinize' x evenDivideDepth++joinize' [] _ = Nil+joinize' [a] _ = Single a+joinize' x n = if n > 0 then let (x1,x2) = splitAt d x+ n = length x+ d = (n `div` 2)+ in Times (joinize' x1 (n-1)) (joinize' x2 (n-1))+ else foldr (\a r -> Times (Single a) r) Nil x++-- | Conversion from a join list to a usual list. +-- +dejoinize :: forall a. JoinList a -> [a]+dejoinize x = dejoinize' x []++dejoinize' (Times x1 x2) x = dejoinize' x1 $ dejoinize' x2 x+dejoinize' (Single a) x = a:x+dejoinize' (Nil) x = x++instance Show a => Show (JoinList a) where+ showsPrec d x = showsPrec d (dejoinize x)++instance Read a => Read (JoinList a) where+ readsPrec d x = map (\(y, s)->(joinize y, s)) (readsPrec d x)++instance Eq a => Eq (JoinList a) where+ (==) x y = dejoinize x == dejoinize y++instance Ord a => Ord (JoinList a) where+ compare x y = compare (dejoinize x) (dejoinize y)++++-- 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+++-- | This generates all permutations of a given list.+-- +-- For example, +-- +-- >>> perms "hoge" `aggregateBy` result+-- Bag ["hoge","hoeg","ohge","oheg","hgoe","hgeo","ghoe","gheo","heog","hego","ehog","ehgo","oghe","ogeh","gohe","goeh","oehg","oegh","eohg","eogh","geho","geoh","egho","egoh"]+-- +-- +perms :: [a] -> Semiring a s -> s+perms x = assigns (zip [1..n] x) [1..n] `transformBy` mapMap fst `filterBy` spans n `transformBy` mapMap snd+ where n = length x++spans n = ok <.> homJ' times single nil where+ ok x = IntSet.size x == n+ nil = IntSet.empty+ single (v,_) = IntSet.singleton v+ times = IntSet.union++-- | A transfomer that applies given function to every element in every list in a given bag.+mapMap :: (b -> b') -> GenericSemiring (JoinListAlgebra b') a -> GenericSemiring (JoinListAlgebra b) a+mapMap f (GenericSemiring {..}) = + GenericSemiring {algebra=algebra',monoid=monoid} where+ JoinListAlgebra{..} = algebra+ algebra' = JoinListAlgebra{times=times,single=single.f,nil=nil}+++segsJ :: JoinList a -> Semiring a s -> s+segsJ x (GenericSemiring {..}) = + let (s, _, _, _) = segs' x+ in s `oplus` nil + where segs' = hom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (s1, i1, t1, a1) = x1+ (s2, i2, t2, a2) = x2+ in ((s1 `oplus` s2) `oplus` (t1 `times` i2), i1 `oplus` (a1 `times` i2), (t1 `times` a2) `oplus`t2, a1 `times` a2)+ single' a = let sa = single a in (sa, sa, sa, sa)+ nil' = (identity, identity, identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid+ +initsJ :: JoinList a -> Semiring a s -> s+initsJ x (GenericSemiring {..}) = + let (i, _) = inits' x+ in nil `oplus` i+ where inits' = hom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (i1, a1) = x1+ (i2, a2) = x2+ in (i1 `oplus` (a1 `times` i2), a1 `times` a2)+ single' a = let sa = single a in (sa, sa)+ nil' = (identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++tailsJ :: JoinList a -> Semiring a s -> s+tailsJ x (GenericSemiring {..}) = + let (t, _) = tails' x+ in t `oplus` nil+ where tails' = hom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (t1, a1) = x1+ (t2, a2) = x2+ in ((t1 `times` a2) `oplus`t2, a1 `times` a2)+ single' a = let sa = single a in (sa, sa)+ nil' = (identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++subsJ :: JoinList a -> Semiring a s -> s+subsJ x (GenericSemiring {..}) = subs' x+ where subs' = hom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = single a `oplus` nil+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid+ +assignsJ :: [m] -> JoinList a -> Semiring (m,a) s -> s+assignsJ ms x (GenericSemiring {..}) = assigns' x+ where assigns' = hom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = foldr oplus identity [single (m, a) | m <- ms]+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++assignsByJ :: (a -> [m]) -> JoinList a -> Semiring (m,a) s -> s+assignsByJ f x (GenericSemiring {..}) = assigns' x+ where assigns' = hom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = foldr oplus identity [single (m, a) | m <- f a]+ JoinListAlgebra {..} = algebra+ 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)+ paths' (BinLeaf a) = single a+ JoinListAlgebra {..} = algebra+ 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++segsJP :: (NFData s) => JoinList a -> Semiring a s -> s+segsJP x (GenericSemiring {..}) = + let (s, _, _, _) = segs' x+ in s `oplus` nil + where segs' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (s1, i1, t1, a1) = x1+ (s2, i2, t2, a2) = x2+ in ((s1 `oplus` s2) `oplus` (t1 `times` i2), i1 `oplus` (a1 `times` i2), (t1 `times` a2) `oplus`t2, a1 `times` a2)+ single' a = let sa = single a in (sa, sa, sa, sa)+ nil' = (identity, identity, identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid+ ++-- | Parallel version of `inits`. +-- +initsP :: (NFData s) => [a] -> Semiring a s -> s+initsP = initsJP.joinize++initsJP :: (NFData s) => JoinList a -> Semiring a s -> s+initsJP x (GenericSemiring {..}) = + let (i, _) = inits' x+ in nil `oplus` i+ where inits' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (i1, a1) = x1+ (i2, a2) = x2+ in (i1 `oplus` (a1 `times` i2), a1 `times` a2)+ single' a = let sa = single a in (sa, sa)+ nil' = (identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++-- | Parallel version of `tails`. +-- +tailsP :: (NFData s) => [a] -> Semiring a s -> s+tailsP = tailsJP.joinize++tailsJP :: (NFData s) => JoinList a -> Semiring a s -> s+tailsJP x (GenericSemiring {..}) = + let (t, _) = tails' x+ in t `oplus` nil+ where tails' = parallelJoinListHom (JoinListAlgebra {times=times',single=single',nil=nil'})+ times' x1 x2 = + let (t1, a1) = x1+ (t2, a2) = x2+ in ((t1 `times` a2) `oplus`t2, a1 `times` a2)+ single' a = let sa = single a in (sa, sa)+ nil' = (identity, nil)+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++-- | Parallel version of `subs`. +-- +subsP :: (NFData s) => [a] -> Semiring a s -> s+subsP = subsJP.joinize++subsJP :: (NFData s) => JoinList a -> Semiring a s -> s+subsJP x (GenericSemiring {..}) = subs' x+ where subs' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = single a `oplus` nil+ 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+assignsJP ms x (GenericSemiring {..}) = assigns' x+ where assigns' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = foldr oplus identity [single (m, a) | m <- ms]+ 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+assignsByJP f x (GenericSemiring {..}) = assigns' x+ where assigns' = parallelJoinListHom (JoinListAlgebra {times=times,single=single',nil=nil})+ single' a = foldr oplus identity [single (m, a) | m <- f a]+ JoinListAlgebra {..} = algebra+ CommutativeMonoid {..} = monoid++-- | Parallel version of `perms`. +-- +permsP :: (NFData s) => [a] -> Semiring a s -> s+permsP x = assignsP (zip [1..n] x) [1..n] `transformBy` mapMap fst `filterBy` spans n `transformBy` mapMap snd+ where n = length x++parallelJoinListHom :: forall t a. (NFData a) => JoinListAlgebra t a -> JoinList t -> a+parallelJoinListHom (JoinListAlgebra {..}) = h evenDivideDepth+ where h n (x1 `Times` x2) = if n > 0 then p1 `par` (p2 `pseq` (p1 `times` p2)) else p1 `times` p2+ where p1 = h (n-1) x1+ p2 = h (n-1) x2+ h _ (Single a) = single a+ 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,7 +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). --}+-- | 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@@ -13,81 +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-> }---}+-- | 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'-> }- --}+-- | 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-> ---}+-- | 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@.--}+-- | 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
src/GTA/Util/TypeInfo.hs view
@@ -1,35 +1,30 @@-{- ---}---{-|- 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.-- This code is based on the @Derive@ module from the SYB3 code distribution,- (C) 2005, Ralf Laemmel and Simon Peyton Jones, see- <http://homepages.cwi.nl/~ralf/syb3/code.html>.--}+-- |+-- 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.+-- +-- This code is based on the @Derive@ module from the SYB3 code distribution,+-- (C) 2005, Ralf Laemmel and Simon Peyton Jones, see+-- <http://homepages.cwi.nl/~ralf/syb3/code.html>.+-- module GTA.Util.TypeInfo (TypeInfo, typeInfo, simpleName) where import Language.Haskell.TH -{-|- The first part is the name, the second - a list of type parameters,- the third - a list of constructors. For each constructor we have a name- and a list describing constructor fields.--}+-- |+-- The first part is the name, the second - a list of type parameters,+-- the third - a list of constructors. For each constructor we have a name+-- and a list describing constructor fields.+-- --type TypeInfo = (Name, [Name], [(Name, [(Maybe Name, Type)])]) type TypeInfo = (Name, [TyVarBndr], [(Name, [(Maybe Name, Type)])]) -{-|- Returns type information of a given type.--}+-- |+-- Returns type information of a given type.+-- typeInfo :: Name -> Q TypeInfo typeInfo name = do info' <- reify name@@ -63,9 +58,9 @@ name (NewtypeD _ n _ _ _) = n name d = error $ show d -{-|- Apply 'nameBase' to the name.--}+-- |+-- Apply 'nameBase' to the name.+-- simpleName :: Name -> Name simpleName = mkName . nameBase
test/test.hs view
@@ -13,6 +13,8 @@ test_knapsack = knapsack w items @=? AddIdentity(40) +prop_knapsack w items = knapsack w items == AddIdentity (knapsack' w items)+ main :: IO () main = flip catch print $ defaultMain tests @@ -31,3 +33,8 @@ getValue (w, v) = v items = [(1, 10), (4, 20), (2,30)] w = 5++subs' [] = [[]]+subs' (a:x) = let ss = subs' x in map (a:) ss ++ ss+knapsack' w items = maximum $ map (sum.map getValue)$ filter ((<=w) . sum . map getWeight) $ subs' items+