GTALib 0.0.3 → 0.0.4

raw patch · 5 files changed

+324/−55 lines, 5 filesdep +deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• GTALib.cabal +4/−4
• src/GTA/Core.hs +8/−1
• src/GTA/Data/BinTree.hs +11/−10
• src/GTA/Data/ConsList.hs +178/−0
• src/GTA/Data/JoinList.hs +123/−40

@@ -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.3
+Version:             0.0.4
 
 -- A short (one-line) description of the package.
 Synopsis: A library for GTA programming           
@@ -52,12 +52,12 @@ 
 Library
   -- Modules exported by the library.
-  Exposed-modules:     GTA.Core, GTA.Util.TypeInfo, GTA.Util.GenericSemiringStructureTemplate, GTA.Data.JoinList, GTA.Data.BinTree
+  Exposed-modules:     GTA.Core, GTA.Util.TypeInfo, GTA.Util.GenericSemiringStructureTemplate, GTA.Data.JoinList, GTA.Data.ConsList, GTA.Data.BinTree
   
   -- Packages needed in order to build this package.
-  Build-depends:    base>=4.3 && < 4.6,template-haskell>=2.5 && <2.8,containers>=0.4 && <0.6,parallel >=3.1 && < 3.3
+  Build-depends:    base>=4.3 && < 4.6,template-haskell>=2.5 && <2.8,containers>=0.4 && <0.6,parallel >=3.1 && < 3.3, deepseq >=1.1 && < 1.4
   HS-source-dirs:   src/
-  -- GHC-options:    -Wall   -O
+  --GHC-options:    -Wall   -O
   
   -- Modules not exported by this package.
   -- Other-modules:       

@@ -4,11 +4,14 @@ 
 import Data.List
 import Data.Map (Map,empty, singleton, unionWith,assocs)
-
+import Control.DeepSeq
 
 -- The bag
 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
 
@@ -199,6 +202,10 @@   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 = ()
 
 addIdentity :: forall a. a -> AddIdentity a
 addIdentity a = AddIdentity a

@@ -35,7 +35,7 @@         f' l r = [nodeLV l r]
         n = length x
         merge ts k = 
-            let vs = transpose (map (\(i, x) -> drop i x) (zip [1..k] ts))
+            let vs = transpose (map (\(i, y) -> drop i y) (zip [1..k] ts))
                 hs = map reverse (transpose ts)
                 ns = zipWith mrg hs vs
             in ns:ts
@@ -200,15 +200,16 @@    change the intermediate data structure from B to A
 -}
 assignTrans :: [b] -> [c] -> BinTreeSemiring c (b, a) s -> LVTreeSemiring a s
-assignTrans msl msn bts = GenericSemiring {..} where
-  (monoid, algebra') = let GenericSemiring {..} = bts 
-                                 in (monoid, algebra)
-  BinTreeAlgebra {..} = algebra'
-  CommutativeMonoid {..} = monoid
-  bigOplus = foldr oplus identity
-  algebra = LVTreeAlgebra {..} where
-    nodeLV l r = bigOplus [binNode m l r | m <- msn]
-    leafLV a = bigOplus [binLeaf (m, a) | m <- msl]
+assignTrans msl msn bts = GenericSemiring {monoid=monoid'',algebra=algebra''} 
+    where
+      (monoid'', algebra') = let GenericSemiring {..} = bts 
+                             in (monoid, algebra)
+      BinTreeAlgebra {..} = algebra'
+      CommutativeMonoid {..} = monoid''
+      bigOplus = foldr oplus identity
+      algebra'' = LVTreeAlgebra {..} where
+          nodeLV l r = bigOplus [binNode m l r | m <- msn]
+          leafLV a = bigOplus [binLeaf (m, a) | m <- msl]
 
 
 ---generators

@@ -0,0 +1,178 @@+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell  #-}
+
+{-
+  Definitions for applying the generic GTA framework to cons lists.
+  (we can make a concise, specialized GTA framework for cons-lists, but...)
+ -}
+
+module GTA.Data.ConsList (ConsList(Cons, Nil), ConsListAlgebra(ConsListAlgebra), cons, nil, consize, deconsize, segs, inits, tails, subs, assigns, assignsBy, paths, mapC, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, crossCons, emptyBag, bagOfNil, bagUnion, ConsSemiring, foldr') where
+
+
+import GTA.Core
+import GTA.Util.GenericSemiringStructureTemplate
+import GTA.Data.BinTree (BinTree (..))
+
+
+-- cons list = the usual list in FP
+data ConsList a = Cons a (ConsList a)
+                | Nil
+--             deriving (Show, Eq, Ord, Read)
+ 
+-- to use the GTA framework
+genAllDecl ''ConsList
+
+-- stupid consize function
+consize :: forall a. [a] -> ConsList a
+consize = foldr Cons Nil
+
+-- stupid deconsize function
+deconsize :: forall a. ConsList a -> [a]
+deconsize = hom (ConsListAlgebra{cons=(:),nil=[]})
+            --this hom is of GenericSemiringStructure, namely, foldr
+
+instance Show a => Show (ConsList a) where
+    showsPrec d x = showsPrec d (deconsize x)
+
+instance Read a => Read (ConsList a) where
+    readsPrec d x = map (\(y, s)->(consize y, s)) (readsPrec d x)
+
+instance Eq a => Eq (ConsList a) where
+    (==) x y = deconsize x == deconsize y
+
+instance Ord a => Ord (ConsList a) where
+    compare x y = compare (deconsize x) (deconsize y)
+
+-- short-cut to ConsListAlgebra
+
+foldr' :: forall a s.(a -> s -> s) -> s -> ConsListAlgebra a s
+foldr' f e = ConsListAlgebra {cons = f, nil = e}
+
+
+-- renaming
+type ConsSemiring a s= GenericSemiring (ConsListAlgebra a) s
+
+segs :: [a] -> ConsSemiring a s -> s
+segs x (GenericSemiring {..}) = 
+    let (s, i) = foldr cons' nil' x
+    in i `oplus` s 
+    where cons' a (s, i) = (i `oplus` s, cons a (nil `oplus` i))
+          nil' = (nil, identity)
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+          
+inits :: [a] -> ConsSemiring a s -> s
+inits x (GenericSemiring {..}) = foldr cons' nil x
+    where cons' a i = nil `oplus` cons a i
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+
+tails :: [a] -> ConsSemiring a s -> s
+tails x (GenericSemiring {..}) = 
+    let (t, _) = foldr cons' nil' x
+    in t 
+    where cons' a (t, w) = let aw = cons a w
+                           in ( aw `oplus` t, aw)
+          nil' = (nil, nil)
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+
+subs :: [a] -> ConsSemiring a s -> s
+subs x (GenericSemiring {..}) = foldr cons' nil x
+    where cons' a y = cons a y `oplus` y
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+          
+assigns :: [m] -> [a] -> ConsSemiring (m,a) s -> s
+assigns ms x (GenericSemiring {..}) = foldr cons' nil x
+    where cons' a y = foldr oplus identity [cons (m, a) y | m <- ms]
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+
+assignsBy :: (a -> [m]) -> [a] -> ConsSemiring (m,a) s -> s
+assignsBy f x (GenericSemiring {..}) = foldr cons' nil x
+    where cons' a y = foldr oplus identity [cons (m, a) y | m <- f a]
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+
+{- 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
+    where paths' (BinNode a l r) = cons a (paths' l `oplus` paths' r)
+          paths' (BinLeaf a) = cons a nil
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+
+-- useful function to map
+mapC :: forall b a. (b -> a) -> ConsListMapFs b a
+mapC f = ConsListMapFs {..} where consF = f
+
+-- ConsList-semiring for counting
+count :: Num a => ConsSemiring b a
+count = sumproductBy (ConsListMapFs {consF = const 1})
+
+
+{- simplified aggregators -}
+
+maxsum :: (Ord a, Num a) => ConsSemiring a (AddIdentity a)
+maxsum = maxsumBy (ConsListMapFs {consF = addIdentity})
+
+maxsumsolution :: (Ord a, Num a) => ConsSemiring a (AddIdentity a, Bag (ConsList a))
+maxsumsolution = maxsumsolutionBy (ConsListMapFs {consF = addIdentity})
+
+maxsumWith :: (Ord a, Num a) => (b -> a) -> ConsSemiring b (AddIdentity a)
+maxsumWith f = maxsumBy (mapC (addIdentity.f))
+
+maxsumKWith :: (Ord a, Num a) => Int -> (b -> a) -> ConsSemiring b ([AddIdentity a])
+maxsumKWith k f = maxsumKBy k (mapC (addIdentity.f))
+
+maxsumsolutionXKWith :: (Ord a, Num a) =>
+                       ConsSemiring c b -> Int -> (c -> a) -> ConsSemiring c [(AddIdentity a, b)]
+maxsumsolutionXKWith s k f = maxsumsolutionXKBy s k (mapC (addIdentity.f)) 
+
+maxsumsolutionXWith :: (Ord a, Num a) =>
+                       ConsSemiring c b -> (c -> a) -> ConsSemiring c (AddIdentity a, b)
+maxsumsolutionXWith s f = maxsumsolutionXBy s (mapC (addIdentity.f))
+
+maxsumsolutionWith :: (Ord a, Num a) => (b -> a) -> ConsSemiring b (AddIdentity a, Bag (ConsList b))
+maxsumsolutionWith f = maxsumsolutionBy (mapC (addIdentity.f))
+
+maxsumsolutionKWith :: (Ord a, Num a) => Int -> (b -> a) -> ConsSemiring b [(AddIdentity a, Bag (ConsList b))]
+maxsumsolutionKWith k f = maxsumsolutionKBy k (mapC (addIdentity.f))
+
+maxprodWith :: (Ord a, Num a) => (b -> a) -> ConsSemiring b (AddIdentity a)
+maxprodWith f = maxprodBy (mapC (addIdentity.f)) 
+
+maxprodKWith :: (Ord a, Num a) => Int -> (b -> a) -> ConsSemiring b ([AddIdentity a])
+maxprodKWith k f = maxprodKBy k (mapC (addIdentity.f))
+
+maxprodsolutionXKWith :: (Ord a, Num a) =>
+                       ConsSemiring c b -> Int -> (c -> a) -> ConsSemiring c [(AddIdentity a, b)]
+maxprodsolutionXKWith s k f = maxprodsolutionXKBy s k (mapC (addIdentity.f))
+maxprodsolutionXWith :: (Ord a, Num a) =>
+                       ConsSemiring c b -> (c -> a) -> ConsSemiring c (AddIdentity a, b)
+maxprodsolutionXWith s f = maxprodsolutionXBy s (mapC (addIdentity.f))
+
+maxprodsolutionWith :: (Ord a, Num a) => (b -> a) -> ConsSemiring b (AddIdentity a, Bag (ConsList b))
+maxprodsolutionWith f = maxprodsolutionBy (mapC (addIdentity.f))
+
+maxprodsolutionKWith :: (Ord a, Num a) => Int -> (b -> a) -> ConsSemiring b [(AddIdentity a, Bag (ConsList b))]
+maxprodsolutionKWith k f = maxprodsolutionKBy k (mapC (addIdentity.f))
+
+
+
+--- useful functions to design generators: constructors of bags of lists
+crossCons :: a -> Bag (ConsList a) -> Bag (ConsList a)
+crossCons = cons (algebra freeSemiring)
+
+bagOfNil :: Bag (ConsList a)
+bagOfNil =  nil (algebra freeSemiring)
+
+emptyBag :: Bag (ConsList a)
+emptyBag = let GenericSemiring{..} = freeSemiring :: GenericSemiring (ConsListAlgebra a) (Bag (ConsList a))
+           in identity monoid 
+
+bagUnion :: Bag (ConsList a) -> Bag (ConsList a) -> Bag (ConsList a)
+bagUnion = let GenericSemiring{..} = freeSemiring :: GenericSemiring (ConsListAlgebra a) (Bag (ConsList a))
+           in oplus monoid
+
+

@@ -1,21 +1,28 @@ {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell  #-}
 
-module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra), times, single, nil, joinize, dejoinize, segs, inits, tails, subs, assigns, paths, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP, crossConcat, bagOfSingleton, emptyBag, bagOfNil, bagUnion, Semiring) where
+module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra), times, single, nil, joinize, dejoinize, segs, inits, tails, subs, assigns, paths, assignsBy, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP, assignsByP, crossConcat, bagOfSingleton, emptyBag, bagOfNil, bagUnion, Semiring) where
 
 
 import GTA.Core
 import GTA.Util.GenericSemiringStructureTemplate
 import GTA.Data.BinTree (BinTree (..))
 import Control.Parallel
-
-{- example of the usual semirings -}
-
+import Control.DeepSeq
+    
 -- join list = associative binary tree
 data JoinList a = Times (JoinList a) (JoinList a)
                 | Single a
                 | Nil
 --             deriving (Show, Eq, Ord, Read)
 
+-- to use the GTA framework
+genAllDecl ''JoinList
+
+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
 joinize :: forall a. [a] -> JoinList a
 joinize [] = Nil
@@ -35,7 +42,7 @@     showsPrec d x = showsPrec d (dejoinize x)
 
 instance Read a => Read (JoinList a) where
-    readsPrec d x = map (\(x, s)->(joinize x, s)) (readsPrec d x)
+    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
@@ -44,30 +51,28 @@     compare x y = compare (dejoinize x) (dejoinize y)
 
 
--- to use the GTA framework
-genAllDecl ''JoinList
 
 -- renaming
 type Semiring a s= GenericSemiring (JoinListAlgebra a) s
 
-sequentialJoinListHom :: forall t a. JoinListAlgebra t a -> JoinList t -> a
-sequentialJoinListHom = hom
 segs :: [a] -> Semiring a s -> s
-segs = segsJ sequentialJoinListHom.joinize
+segs = segsJ.joinize
 inits :: [a] -> Semiring a s -> s
-inits = initsJ sequentialJoinListHom.joinize
+inits = initsJ.joinize
 tails :: [a] -> Semiring a s -> s
-tails = tailsJ sequentialJoinListHom.joinize
+tails = tailsJ.joinize
 subs :: [a] -> Semiring a s -> s
-subs = subsJ sequentialJoinListHom.joinize
+subs = subsJ.joinize
 assigns :: [m] -> [a] -> Semiring (m, a) s -> s
-assigns ms = assignsJ sequentialJoinListHom ms.joinize
+assigns ms = assignsJ ms.joinize
+assignsBy :: (a -> [m]) -> [a] -> Semiring (m, a) s -> s
+assignsBy f = assignsByJ f.joinize
 
-segsJ :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
-segsJ h x (GenericSemiring {..}) = 
+segsJ :: JoinList a -> Semiring a s -> s
+segsJ x (GenericSemiring {..}) = 
     let (s, _, _, _) = segs' x
     in s `oplus` nil 
-    where segs' = h (JoinListAlgebra {times=times',single=single',nil=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
@@ -77,11 +82,11 @@           JoinListAlgebra {..} = algebra
           CommutativeMonoid {..} = monoid
           
-initsJ :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
-initsJ h x (GenericSemiring {..}) = 
+initsJ :: JoinList a -> Semiring a s -> s
+initsJ x (GenericSemiring {..}) = 
     let (i, _) = inits' x
     in nil `oplus` i
-    where inits' = h (JoinListAlgebra {times=times',single=single',nil=nil'})
+    where inits' = hom (JoinListAlgebra {times=times',single=single',nil=nil'})
           times' x1 x2 = 
               let (i1, a1) = x1
                   (i2, a2) = x2
@@ -91,11 +96,11 @@           JoinListAlgebra {..} = algebra
           CommutativeMonoid {..} = monoid
 
-tailsJ :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
-tailsJ h x (GenericSemiring {..}) = 
+tailsJ :: JoinList a -> Semiring a s -> s
+tailsJ x (GenericSemiring {..}) = 
     let (t, _) = tails' x
     in t `oplus` nil
-    where tails' = h (JoinListAlgebra {times=times',single=single',nil=nil'})
+    where tails' = hom (JoinListAlgebra {times=times',single=single',nil=nil'})
           times' x1 x2 = 
               let (t1, a1) = x1
                   (t2, a2) = x2
@@ -105,20 +110,27 @@           JoinListAlgebra {..} = algebra
           CommutativeMonoid {..} = monoid
 
-subsJ :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
-subsJ h x (GenericSemiring {..}) = subs' x
-    where subs' = h (JoinListAlgebra {times=times,single=single',nil=nil})
+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 :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> [m] -> JoinList a -> Semiring (m,a) s -> s
-assignsJ h ms x (GenericSemiring {..}) = assigns' x
-    where assigns' = h (JoinListAlgebra {times=times,single=single',nil=nil})
+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 -}
 paths :: BinTree a a -> Semiring a s -> s
 paths x (GenericSemiring {..}) = paths' x
@@ -186,18 +198,89 @@ 
 --- parallel generators
 
-segsP :: [a] -> Semiring a s -> s
-segsP = segsJ parallelJoinListHom.joinize
-initsP :: [a] -> Semiring a s -> s
-initsP = initsJ parallelJoinListHom.joinize
-tailsP :: [a] -> Semiring a s -> s
-tailsP = tailsJ parallelJoinListHom.joinize
-subsP :: [a] -> Semiring a s -> s
-subsP = subsJ parallelJoinListHom.joinize
-assignsP :: [m] -> [a] -> Semiring (m, a) s -> s
-assignsP ms = assignsJ parallelJoinListHom ms.joinize
+segsP :: (NFData s) => [a] -> Semiring a s -> s
+segsP = segsJP.joinize
 
-parallelJoinListHom :: forall t a. JoinListAlgebra t a -> JoinList t -> a
+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
+          
+
+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
+
+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
+
+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
+          
+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
+
+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