Commits

Anonymous committed 91e326a

added ConsList. modified to use DeepSeq in the parallel computation

Comments (0)

Files changed (6)

 -- 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           
 
 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
   

examples/Knapsack.hs

 
 ghc Knapsack.hs -threaded -rtsopts -O2
 
-time ./Knapsack.exe +RTS -N1 -RTS
-time ./Knapsack.exe +RTS -N2 -RTS
-time ./Knapsack.exe +RTS -N4 -RTS
-time ./Knapsack.exe +RTS -N8 -RTS
+time ./Knapsack +RTS -N1 -RTS
+time ./Knapsack +RTS -N2 -RTS
+time ./Knapsack +RTS -N4 -RTS
+time ./Knapsack +RTS -N8 -RTS
 
 -}
 
 descending :: (Ord w) => 
               (Maybe (w, Bool, w) -> Bool,
                JoinListAlgebra (w, v) (Maybe (w, Bool, w)))
-descending = (\a -> case a of Just (_, t, _) -> t; Nothing -> False) <.> h where
+descending = maybe True (\(_, t, _) -> t) <.> h where
   h = JoinListAlgebra{..} 
   Just (l1, t1, r1) `times` Just (l2, t2, r2) = Just (l1, t1 && t2 && (r1 > l2), r2)
   Nothing `times` x = x

examples/KnapsackCons.hs

+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+import GTA.Data.ConsList
+import GTA.Core hiding (items)
+
+import System.Random
+
+{- Demonstration
+
+:l *KnapsackCons.hs
+
+subs [(1, 30), (2, 20), (2, 40)] `aggregateBy` result
+
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` result
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionWith getValue
+
+items <- randomItems 200 200
+length items
+
+:set +s
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+subs items `aggregateBy` count
+
+
+items <- randomItems 400 200
+length items
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+items <- randomItems 800 200
+length items
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+items <- randomItems 1600 200
+length items
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+
+
+-}
+
+-- a naive program looking like a exponential cost program
+knapsack capa items = 
+  subs items 
+    `filterBy` weightlimit capa
+    `aggregateBy` maxsumsolutionWith getValue
+
+
+--main function to check the heacy computation
+main = do
+  let w = 200
+  let n = 20000
+  items <- randomItems n w
+  putStrLn $ "w=" ++ show w ++ ", #items = " ++ show n
+  putStrLn.show $ knapsack w items
+
+{-
+
+ghc Knapsack.hs -rtsopts -O2
+
+time ./Knapsack 
+
+-}
+
+{-
+Selecting a generator: 
+
+segs [1,2,3] `aggregateBy` result
+inits [1,2,3] `aggregateBy` result
+tails [1,2,3] `aggregateBy` result
+subs [1,2,3] `aggregateBy` result
+assigns "TF" [1,2,3] `aggregateBy` result
+
+
+subs [(1, 30), (2, 20), (2, 40)] `aggregateBy` result
+-}
+
+{-
+Designing a predicate (tester)
+-}
+-- the base definition of user-defined predicate to check the weight limit
+-- Please define it as a composition of lightweight function + foldr
+weightlimit' w = (<=w) . foldr f e where 
+   f a x = getWeight a + x
+   e = 0
+{-
+weightlimit' 3 $ [(1,30), (2,20)]
+weightlimit' 3 $ [(1,30), (2,20), (2,40)]
+-}
+
+-- the range of the foldr becomes smaller
+weightlimit'' w = (<=w) . foldr f e where 
+   f a x = (getWeight a + x) `min` (w+1)
+   e = 0
+{-
+weightlimit'' 3 $ [(1,30), (2,20)]
+weightlimit'' 3 $ [(1,30), (2,20), (2,40)]
+-}
+
+{-
+  MACHINICALLY rewrite it:
+    (composition)  .    -> <.>
+    (foldr)        foldr-> foldrC
+-}
+weightlimit w = (<=w) <.> foldrC f e where 
+   f a x = (getWeight a + x) `min` (w+1)
+   e = 0
+
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` result
+-}
+
+{-
+Selecting an aggregator: 
+
+-- knapsack problem
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionWith getValue
+
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionWith (\i -> let v = getValue i in if v == 40 then 0 else v)
+
+-}
+
+{-
+Modified knapsack problem solvers via aggregators
+
+-- counting the number of valid selections
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` count
+
+-- k-best knapsack
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionKWith 3 getValue
+
+-}
+
+
+
+{-
+Modified knapsack problem solvers via testers
+-}
+
+-- user-defined predicate for divisable-by-3
+multipleOf k = (==0) <.> foldrC f e where
+  f _ x = (1 + x) `mod` k
+  e = 0
+{-
+-- with an additional condition: # of selected items are divisible by 3.
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` multipleOf 3 `aggregateBy` maxsumsolutionWith getValue
+
+subs [(1, 30), (1, 10), (1, 10), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` multipleOf 3 `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+-- user-defined predicate: at most one value item
+oneValueItem v = (<=1) <.> foldrC f e where
+  f i x = ((if getValue i >= v then 1 else 0) + x) `min` 2
+  e = 0 
+
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` oneValueItem 30 `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+-- user-defined predicate: descending in weights
+
+descending :: (Ord w) => 
+              (Maybe (w, Bool) -> Bool,
+               ConsListAlgebra (w, v) (Maybe (w, Bool)))
+descending = maybe True (\(_, t) -> t) <.> foldrC f e where
+  e = Nothing
+  f i x = let w = getWeight i 
+          in maybe (Just (w, True)) (\(wr, t) -> (Just (w, t && wr > w))) x
+
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` descending `aggregateBy` maxsumsolutionWith getValue
+
+subs [(2, 20), (2, 40), (1, 30)] `filterBy` weightlimit 3 `filterBy` descending `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+
+-- =============== for designing a new generator ===========
+{-
+
+let x = bagOfNil `bagUnion` bagOfNil
+x
+let y = crossCons 1 x
+y
+crossCons 2 (y `bagUnion` x)
+
+
+-}
+
+--straightforward imlementation of subs generator on lists:
+subs'' :: [a] -> Bag (ConsList a)
+subs'' x = ss x where
+    ss [] = bagOfNil
+    ss (a:x) = crossCons a (bagOfNil `bagUnion` ss x)
+
+{-
+subs'' [1,2,3]
+
+-}
+
+--abstracted version of subs'':
+subs' :: [a] -> ConsSemiring a s -> s
+subs' x (GenericSemiring {..}) = ss x where
+    ss [] = nil
+    ss (a:x) = cons a (nil `oplus` ss x)
+    ConsListAlgebra {..} = algebra
+    CommutativeMonoid {..} = monoid
+
+{-
+subs' [1,2,3] freeSemiring
+subs' [1,2,3] `aggregateBy` result
+
+-}
+
+
+-- computes the best value only
+knapsackValue capa items = 
+  subs items 
+    `filterBy` weightlimit capa
+    `aggregateBy` maxsumWith getValue
+
+-- another notation
+knapsackValue' w items = 
+  subs items 
+    >== weightlimit w
+    >=> maxsumWith getValue
+
+getWeight (w, v) = w
+getValue (w, v) = v
+exampleItems = [(1, 10), (4, 20), (2,30)]
+examplelimit = 5
+
+{-
+user-defined aggregator
+-}
+--maxvalue:: Semiring (Int, Int) (Maybe Int)
+maxvalue = GenericSemiring{monoid=CommutativeMonoid {..}, 
+                           algebra=ConsListAlgebra {..}} where
+    a `oplus` b = a `max` b
+    identity    = Nothing
+    cons a x    = maybe Nothing (\x -> Just (getValue a + x)) x
+    nil         = Just 0
+
+{-
+
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxvalue
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumWith getValue
+
+
+-}
+
+
+{-
+other versions:
+
+subs items >=> result
+subs items >== weightlimit w >=> result 
+subs items >== weightlimit w >=> result
+subs items >== weightlimit w >=> count 
+subs items >== weightlimit w >=> maxsumWith getValue
+subs items >== weightlimit w >=> maxsumsolutionWith getValue
+subs items >== weightlimit w >=> maxsumsolutionKWith 2 getValue
+subs items >== weightlimit w >=> maxsumsolutionXKWith count 2 getValue
+
+-}
+
+
+
+-- with an additional condition: # of selected items are divisible by 3.
+knapsack3 w items =
+  subs items 
+    `filterBy` weightlimit w 
+    `filterBy` multipleOf 3
+    `aggregateBy` maxsumsolutionWith getValue
+
+
+randomItems :: Int -> Int -> IO ([(Int, Int)])
+randomItems n w = do 
+  setStdGen (mkStdGen 0)  -- always the same random sequence
+  rand <- getStdGen
+  let genItems (v:w:rs) = (v, w):genItems rs
+  return (take n (genItems (randomRs (1, w) rand)))
+
+
 
 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
 
   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
 

src/GTA/Data/ConsList.hs

+{-# 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, paths, mapC, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, crossCons, emptyBag, bagOfNil, bagUnion, ConsSemiring, foldrC) 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 (\(x, s)->(consize x, 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
+foldrC 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 x = cons a x `oplus` x
+          ConsListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+          
+assigns :: [m] -> [a] -> ConsSemiring (m,a) s -> s
+assigns ms x (GenericSemiring {..}) = foldr cons' nil x
+    where cons' a x = foldr oplus identity [cons (m, a) x | m <- ms]
+          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
+
+

src/GTA/Data/JoinList.hs

 import GTA.Util.GenericSemiringStructureTemplate
 import GTA.Data.BinTree (BinTree (..))
 import Control.Parallel
-
+import Control.DeepSeq
+    
 {- example of the usual semirings -}
 
 -- join list = associative binary tree
                 | 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
     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
 
-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
           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
           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
           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
 
 --- 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
-
-parallelJoinListHom :: forall t a. JoinListAlgebra t a -> JoinList t -> a
+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
+          
+
+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
+
+
+
+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