Commits

U-darkstar\KE  committed 2d63cdd

cleaned, added assignsBy

  • Participants
  • Parent commits 91e326a

Comments (0)

Files changed (5)

File GTALib.cabal

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

File examples/KnapsackCons.hs

 weightlimit' 3 $ [(1,30), (2,20), (2,40)]
 -}
 
--- the range of the foldr becomes smaller
+-- now, make the range of the foldr as small as possible
 weightlimit'' w = (<=w) . foldr f e where 
    f a x = (getWeight a + x) `min` (w+1)
    e = 0
 -}
 
 {-
-  MACHINICALLY rewrite it:
+Finally, rewrite it MACHINICALLY:
     (composition)  .    -> <.>
-    (foldr)        foldr-> foldrC
+    (foldr)        foldr-> foldr'
 -}
-weightlimit w = (<=w) <.> foldrC f e where 
+weightlimit w = (<=w) <.> foldr' f e where 
    f a x = (getWeight a + x) `min` (w+1)
    e = 0
 
 {-
+--Now, we can use the tester in our GTA program.
+
 subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` result
 -}
 
 -}
 
 -- user-defined predicate for divisable-by-3
-multipleOf k = (==0) <.> foldrC f e where
+multipleOf k = (==0) <.> foldr' f e where
   f _ x = (1 + x) `mod` k
   e = 0
 {-
 -}
 
 -- user-defined predicate: at most one value item
-oneValueItem v = (<=1) <.> foldrC f e where
+oneValueItem v = (<=1) <.> foldr' f e where
   f i x = ((if getValue i >= v then 1 else 0) + x) `min` 2
   e = 0 
 
 descending :: (Ord w) => 
               (Maybe (w, Bool) -> Bool,
                ConsListAlgebra (w, v) (Maybe (w, Bool)))
-descending = maybe True (\(_, t) -> t) <.> foldrC f e where
+descending = maybe True (\(_, t) -> t) <.> foldr' 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

File src/GTA/Data/BinTree.hs

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

File src/GTA/Data/ConsList.hs

   (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
+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
     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)
+    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
     compare x y = compare (deconsize x) (deconsize y)
 
 -- short-cut to ConsListAlgebra
-foldrC f e = ConsListAlgebra {cons = f, nil = e}
+
+foldr' :: forall a s.(a -> s -> s) -> s -> ConsListAlgebra a s
+foldr' f e = ConsListAlgebra {cons = f, nil = e}
 
 
 -- renaming
 
 subs :: [a] -> ConsSemiring a s -> s
 subs x (GenericSemiring {..}) = foldr cons' nil x
-    where cons' a x = cons a x `oplus` 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 x = foldr oplus identity [cons (m, a) x | m <- ms]
+    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
 

File src/GTA/Data/JoinList.hs

 {-# 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 Control.Parallel
 import Control.DeepSeq
     
-{- example of the usual semirings -}
-
 -- join list = associative binary tree
 data JoinList a = Times (JoinList a) (JoinList a)
                 | Single a
     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
 subs = subsJ.joinize
 assigns :: [m] -> [a] -> Semiring (m, a) s -> s
 assigns ms = assignsJ ms.joinize
+assignsBy :: (a -> [m]) -> [a] -> Semiring (m, a) s -> s
+assignsBy f = assignsByJ f.joinize
 
 segsJ :: JoinList a -> Semiring a s -> s
 segsJ x (GenericSemiring {..}) = 
           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
           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