1. Kento Emoto
  2. GTALib

Commits

U-artemis\kento  committed 532621a Merge

Merge branch 'master' of bitbucket.org:emoto/gtalib

  • Participants
  • Parent commits 3521e3d, 43a78af
  • Branches master

Comments (0)

Files changed (10)

File GTALib.cabal

View file
  • Ignore whitespace
 -- 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           
    > 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

File examples/TSP.hs

View file
  • Ignore whitespace
+import GTA.Core;
+import GTA.Data.JoinList;
+import qualified Data.IntSet as IntSet
+import System.Environment
+
+
+-- checks whether a given list of edges is a path or not
+isPath = ok <.> homJ' times single nil where
+    ok = maybe False (\_ -> True)
+    nil = Just Nothing
+    single (x, _) = Just $ Just x
+    times Nothing _ = Nothing
+    times _ Nothing = Nothing
+    times (Just Nothing) x = x
+    times x (Just Nothing) = x
+    times (Just (Just (u, v))) (Just ( Just (w, z))) 
+        = if v == w then Just $ Just (u, z) 
+          else Nothing 
+
+-- checks whether a given list of edges is a simple cycle of length n or not
+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
+
+-- generates a list of edges from 1 to 1 including non-simple cycles.
+genEdgeList n = assignsBy (edges n) [1..n]
+edges n m | m == 1 = [(1, k) | k <- [2..n]]
+          | m == n = [(k, 1) | k <- [2..n]]
+          | True   = [(k, l) | k <- [2..n], l <- [2..n], not (k==l)]
+
+-- TSP solver
+tsp dist n = genEdgeList n
+             `filterBy` isPath
+             `filterBy` spans n
+             `aggregateBy` maxsumsolutionWith (revOrd . dist . fst)
+
+-- The answer is 1 -> 2 -> ... -> n -> 1 (and its reverse)
+lineardist (m, n) | m == n - 1 = 1
+                  | n == m - 1 = 1
+                  | m < n = n - m + 1
+                  | True  = m - n + 1
+
+
+-- TSP solver (parallel version)
+tspP dist n = assignsByP (edges n) [1..n]
+             `filterBy` isPath
+             `filterBy` spans n
+             `aggregateBy` maxsumsolutionWith (revOrd . dist . fst)
+
+main = do a <- getArgs
+          let n | length a > 0 = read $ head a
+                | True         = 11
+          putStrLn $ "n = " ++ show n
+          print $ tsp lineardist n
+
+{-
+ghc -threaded -rtsopts TSP.hs -o TSP -O2
+
+time ./TSP 11 +RTS -N1
+time ./TSP 11 +RTS -N2
+
+-}
+
+{- 
+-----------
+Discussion
+-----------
+
+The size of the range of foldr of isPath is n^2+2.
+The size of the range of foldr of spans n is 2^n
+
+Therefore, the size of a table is O(n^2 2^n) .
+
+In total, O(n^5 4^n) algorithm.
+
+-}
+
+
+

File examples/TSPCons.hs

View file
  • Ignore whitespace
+import GTA.Core;
+import GTA.Data.ConsList;
+import qualified Data.IntSet as IntSet
+import System.Environment
+
+-- checks whether a given list of edges is a path or not
+isPath = ok <.> foldr' f e where
+    ok = maybe False (\_ -> True)
+    e = Just Nothing
+    f _ Nothing = Nothing
+    f ((v,_),_) (Just Nothing) = Just $ Just v
+    f ((v,u),_) (Just (Just w)) | u == w = Just $ Just v
+                                | True   =  Nothing
+-- checks whether a given list of edges is a simple cycle of length n or not
+spans n = ok <.> foldr' f e where
+    e = IntSet.empty
+    f ((v,_), _) x = IntSet.insert v x
+    ok x = IntSet.size x == n
+
+-- generates a list of edges from 1 to 1 including non-simple cycles.
+genEdgeList n = assignsBy (edges n) [1..n]
+edges n m | m == 1 = [(1, k) | k <- [2..n]]
+          | m == n = [(k, 1) | k <- [2..n]]
+          | True   = [(k, l) | k <- [2..n], l <- [2..n], not (k==l)]
+
+-- TSP solver
+tsp dist n = genEdgeList n
+             `filterBy` isPath
+             `filterBy` spans n
+             `aggregateBy` maxsumsolutionWith (revOrd . dist . fst)
+
+-- The answer is 1 -> 2 -> ... -> n -> 1 (and its reverse)
+lineardist (m, n) | m == n - 1 = 1
+                  | n == m - 1 = 1
+                  | m < n = n - m + 1
+                  | True  = m - n + 1
+
+main = do a <- getArgs
+          let n | length a > 0 = read $ head a
+                | True         = 11
+          putStrLn $ "n = " ++ show n
+          print $ tsp lineardist n
+
+{-
+ghc TSPCons.hs -o TSPCons -O2 -rtsopts
+
+time ./TSPCons 11
+
+-}
+
+{- 
+-----------
+Discussion
+-----------
+
+The size of the range of foldr of isPath is n+2.
+The size of the range of foldr of spans n is 2^n
+
+Therefore, the size of a table is O(n2^n) .
+
+The number of signs assigned to an element by assignsBy is O(n^2).
+
+The assignsBy updates the table O(n) times.
+
+In total, O(n^4 2^n) algorithm.
+
+This is worse than the well-known DP of TSP by a factor of O(n^2) (perhaps). The reason is that we generate a list of edges so that we can compute the minimum sum by the given aggregator. We might be able to define a new aggregator to avoid this factor. 
+
+-}
+
+
+

File src/GTA/Core.hs

View file
  • Ignore whitespace
-{-# 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
+
+
+
+

File src/GTA/Data/BinTree.hs

View file
  • Ignore whitespace
 {-# 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

File src/GTA/Data/ConsList.hs

View file
  • Ignore whitespace
   (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
           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
            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}

File src/GTA/Data/JoinList.hs

View file
  • Ignore whitespace
-{-# 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 {..}) =