Commits

Anonymous committed 5516e43

init

Comments (0)

Files changed (11)

+-- GTALib.cabal auto-generated by cabal init. For additional options,
+-- see
+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
+-- The name of the package.
+Name:                GTALib
+
+-- 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.1
+
+-- A short (one-line) description of the package.
+Synopsis: A library for GTA programming           
+
+-- A longer description of the package.
+Description: This package 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). (This version is a very early version and dirty. The source files will be cleaned and documented soon.)
+
+-- URL for the project homepage or repository.
+Homepage: https://bitbucket.org/emoto/gtalib
+
+-- The license under which the package is released.
+License:             BSD3
+
+-- The file containing the license text.
+License-file:        LICENSE
+
+-- The package author(s).
+Author:              Kento Emoto
+
+-- An email address to which users can send suggestions, bug reports,
+-- and patches.
+Maintainer:          emoto@mist.i.u-tokyo.ac.jp
+
+-- A copyright notice.
+-- Copyright:           
+
+Category:            Language
+
+Build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+-- Extra-source-files:  
+
+-- Constraint on the version of Cabal needed to build this package.
+Cabal-version:       >=1.8
+Tested-with:         GHC==7.0.4
+
+source-repository head
+  type:    git
+  location: https://bitbucket.org/emoto/gtalib.git
+
+Library
+  -- Modules exported by the library.
+  Exposed-modules:     GTA.Core, GTA.Util.TypeInfo, GTA.Util.GenericSemiringStructureTemplate, GTA.Data.JoinList, GTA.Data.BinTree
+  
+  -- Packages needed in order to build this package.
+  Build-depends:    base,template-haskell,containers,parallel 
+  HS-source-dirs:   src/
+  --GHC-options:    -Wall   -O
+  
+  -- Modules not exported by this package.
+  -- Other-modules:       
+  
+  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
+  -- Build-tools:         
+  
+
+Test-Suite unit-test
+  HS-source-dirs:      test/
+  Type:                exitcode-stdio-1.0
+  Main-is:             test.hs
+  Build-depends:       base,test-framework,GTALib,HUnit,test-framework-hunit
+Copyright (c)2012, Kento Emoto
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Kento Emoto nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+import Distribution.Simple
+main = defaultMain
+{-# LANGUAGE RecordWildCards,RankNTypes  #-}
+
+module CYK where
+
+import GTA.Core
+import GTA.Util.GenericSemiringStructureTemplate
+import Data.Map (singleton, assocs)
+
+import GTA.Data.BinTree
+
+{-
+-- CKY parsing/matrix chain O(n^3)
+-}
+
+
+-- matrix chain
+
+drawLVTree t = drawTree' t
+    where
+      drawTree' (NodeLV l r) = 
+          let a' = "+"
+              ls = drawTree' l
+              rs = drawTree' r
+              ln = length ls
+              rn = length rs
+              an = length a'
+              cs = ls ++ rs
+              ms = div (an-1) 2 + 1 -- position of the edge to the lower child
+              ns = 1 -- distance between the parent and the upper child 
+              rep :: forall a.Int -> a -> [a]
+              rep n x = take n (repeat x)
+              ds = (a'++rep ns '-'):rep (ln-1) (rep (an-ms) ' ' ++ ('|':rep (ns-1+ms) ' '))
+              fs = (rep (an-ms) ' ' ++ ('+':rep (ns-1+ms) '-')):rep (rn-1) (rep (ns+an) ' ')
+          in zipWith (++) (ds++fs) cs
+      drawTree' (LeafLV a) = [show a]
+
+instance (Show a) => Show (LVTree a) where
+  showsPrec _ x s = unlines ("":drawLVTree x) ++ s
+
+data MinCost = Cost (Int, (Int, Int))
+             | IdentityOfMinCost
+               deriving (Show, Eq, Ord, Read)
+mincost = GenericSemiring {..} where
+  monoid = CommutativeMonoid {..} where
+    oplus IdentityOfMinCost b = b
+    oplus a IdentityOfMinCost = a
+    oplus (Cost a) (Cost b) = Cost (a `min` b)
+    identity = IdentityOfMinCost
+  algebra = LVTreeAlgebra {..} where
+    nodeLV IdentityOfMinCost r = IdentityOfMinCost 
+    nodeLV l IdentityOfMinCost = IdentityOfMinCost 
+    nodeLV (Cost (c1, (m1, n1))) (Cost (c2, (m2, n2))) =
+        Cost (c1+c2+m1*n1*n2, (m1, n2))
+             -- assumption: n1 == m2
+    leafLV a = Cost (0, a)
+
+-- the distributivity holds in the restricted case: 
+--  nodeLV ((c1, (m, n)) `min` (c2, (m, n))) r = 
+--     nodeLV (c1, (m, n) r `min` nodeLV (c2, (m, n)) r
+-- this restriction holds while the computation.
+
+mincostsolution :: GenericSemiring (LVTreeAlgebra (Int, Int)) (MinCost, Bag (LVTree (Int, Int)))
+mincostsolution = GenericSemiring {..} where
+  s = freeSemiring :: GenericSemiring (LVTreeAlgebra (Int, Int)) (Bag (LVTree (Int, Int)))
+  monoid = CommutativeMonoid {..} where
+    oplus (a, x) (b, y) 
+      = case compare a b of
+          EQ -> (a, x `oplus'` y)
+          GT -> (b, y)
+          LT -> (a, x)
+    identity = (IdentityOfMinCost, identity')
+  algebra = pairAlgebra maxMonoSumAlgebra algebra'
+  maxMonoSumAlgebra = let GenericSemiring {..} = mincost in algebra
+  (monoid', algebra') = let GenericSemiring {..} = s in (monoid, algebra)
+  (oplus', identity') = let CommutativeMonoid {..} = monoid' in(oplus, identity)
+
+
+-- the matrix chain problem solver
+matrixchain x = lvtrees x >=> mincostsolution
+
+matrices = [(6,4),(4,5),(5,4)]
+
+one = LVTreeMapFs {leafLVF = const 1}
+
+
+{- for demonstration
+
+lvtrees [(6,4),(4,5),(5,4)] >=> result
+lvtrees [(6,4),(4,5),(5,4)] >=> sumproductBy one 
+lvtrees [(6,4),(4,5),(5,4)] >=> mincost
+lvtrees (take 50 (repeat (2,2))) >=> sumproductBy one
+lvtrees (take 50 (repeat (2,2))) >=> mincost
+
+
+-}
+
+-- CYK parsing
+
+drawTree dl dn t = drawTree' t
+    where
+      drawTree' (BinNode a l r) = 
+          let a' = let o = dn a in if o == [] then "+" else o
+              ls = drawTree' l
+              rs = drawTree' r
+              ln = length ls
+              rn = length rs
+              an = length a'
+              cs = ls ++ rs
+              ms = div (an-1) 2 + 1 -- position of the edge to the lower child
+              ns = 1 -- distance between the parent and the upper child 
+              rep :: forall a.Int -> a -> [a]
+              rep n x = take n (repeat x)
+              ds = (a'++rep ns '-'):rep (ln-1) (rep (an-ms) ' ' ++ ('|':rep (ns-1+ms) ' '))
+              fs = (rep (an-ms) ' ' ++ ('+':rep (ns-1+ms) '-')):rep (rn-1) (rep (ns+an) ' ')
+          in zipWith (++) (ds++fs) cs
+      drawTree' (BinLeaf a) = [dl a]
+
+instance (Show n, Show l) => Show (BinTree n l) where
+  showsPrec _ x s = unlines ("":drawTree show show x) ++ s
+
+drawTrees (Bag l) = putStr.unlines.concatMap (++[[]]).map (drawTree dl dn) $ l
+  where 
+    dn m = show m
+    dl (m, a) = (show m ++ show a)
+
+
+
+{-
+traverseLtoR (Node _ l r) = traverseLtoR l ++ traverseLtoR r
+traverseLtoR (Leaf (Left (a, m))) = [a]
+--check l = (\(Bag x) -> and(map ((==l).traverseLtoR) x)) $ (trees [B,L,R] l >=> result)
+-}
+{-
+Balanced Bracket Grammar
+B is the starting symbol. 
+ B -> BB
+ B -> LR
+ L -> LB
+ R -> BR
+ L -> '['
+ R -> ']'
+
+This grammar is ambiguous, e.g., "[[]]" has the following two derivations.
+B-L'['
++-R-B-L'['
+  | +-R']'
+  +-R']'
+
+B-L-L'['
+| +-B-L'['
+|   +-R']'
++-R']'
+
+-}
+data NonTerminal = B | L | R deriving (Show, Eq, Ord, Read)
+
+validProduction = (==Just B) <.> BinTreeAlgebra{..} where 
+  binLeaf (L, '[') = Just L
+  binLeaf (R, ']') = Just R
+  binLeaf _ = Nothing
+  binNode s (Just l) (Just r) 
+    = case (s, l, r) of
+        (B, B, B) -> Just B
+        (B, L, R) -> Just B
+        (L, L, B) -> Just L
+        (R, B, R) -> Just R
+        otherwise -> Nothing
+  binNode _ _ _ = Nothing
+  
+  
+test = parse "[[]]" 
+
+--validParses s = assignTrees [B,L,R] [B,L,R] s >== validProduction 
+validParses s = lvtrees s >=< assignTrans [B,L,R] [B,L,R] >== validProduction
+
+parses s = validParses s >=> result
+
+parse s = drawTrees (parses s)
+{-
+In the above function 'parse', invalid trees are not computed because of the laziness. Thus, it is very fast, though the computation of invalid trees is very heavy (exponential)).
+-}
+countParse s = validParses s >=> count
+
+
+-- maxProduct by preferences
+prefs = BinTreeMapFs {..}
+  where 
+    binLeafF (m, a) = case m of 
+                        B -> AddIdentity 1.0
+                        L -> AddIdentity 1.0
+                        R -> AddIdentity 1.0
+    binNodeF p = case p of 
+                   (B, B, B) -> AddIdentity 1.0
+                   (B, L, R) -> AddIdentity 1.0
+                   (L, L, B) -> AddIdentity 1.0
+                   (R, B, R) -> AddIdentity 0.5
+
+validProduction' = (==Just B) <.> BinTreeAlgebra{..} where 
+  binLeaf (L, '[') = Just L
+  binLeaf (R, ']') = Just R
+  binLeaf _ = Nothing
+  binNode s (Just l) (Just r) 
+      = case (s, l, r) of
+          ((B, B, B), B, B) -> Just B
+          ((B, L, R), L, R) -> Just B
+          ((L, L, B), L, B) -> Just L
+          ((R, B, R), B, R) -> Just R
+          otherwise -> Nothing
+  binNode _ _ _ = Nothing
+
+gen' = assignTrees [B,L,R] [(B,B,B),(B,L,R),(L,L,B),(R,B,R)]
+
+maxPrefParse s = gen' s >== validProduction' >=> maxprodsolutionKBy 3 prefs
+

examples/Knapsack.hs

+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+import GTA.Data.JoinList
+import GTA.Core hiding (items)
+
+import System.Environment
+import System.Random
+
+{-
+subsJ :: JList a -> Bag (JList a)
+subsJ x = ss x
+    where ss (x1 `Times` x2) = ss x1 `cross` ss x2
+          ss (Single a) = single a `u` bagOfnil
+          ss Nil = emptyBag
+
+weightlimit w = (<=w) . ws
+  where 
+       ws (x1 `Times` x2) = (ws x1 + ws x2) `min` (w+1)
+       ws (Single i) = getWeight i `min` (w+1)
+       ws  Nil = 0
+-}
+{-
+subs' :: [a] -> Semiring a s -> s
+subs' = subsJ.joinize
+subsJ :: JList a -> Semiring a s -> s
+subsJ x (GenericSemiring {..}) = ss x
+    where JListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+          ss (x1 `Times` x2) = ss x1 `times` ss x2
+          ss (Single a) = single a `oplus` nil
+          ss Nil = identity          
+-}
+
+weightlimit w = (<=w) <.> ws
+  where ws = JoinListAlgebra{..} where 
+           x1 `times` x2  = (   x1 +    x2) `min` (w+1)
+           single i  = getWeight i `min` (w+1)
+           nil = 0
+
+
+knapsack w items = 
+  subs items 
+    >== weightlimit w
+    >=> maxsumWith getValue
+
+knapsackSolution w items = 
+  subs items 
+    >== weightlimit w
+    >=> maxsumsolutionWith getValue
+
+getWeight (w, v) = w
+getValue (w, v) = v
+items = [(1, 10), (4, 20), (2,30)]
+w = 5
+
+-- another notation
+knapsack' w items = 
+  subs items 
+    `filterBy` weightlimit w
+    `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
+
+-}
+
+
+--parallel version
+knapsackP w items = 
+  subsP items 
+    >== weightlimit w
+    >=> maxsumWith 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
+
+multipleOf k = (==0) <.> length' k
+length' k = JoinListAlgebra{..} where 
+  w1 `times` w2 = (w1 + w2) `mod` k
+  single i = 1 `mod` k
+  nil = 0 `mod` k
+
+main = do
+  setStdGen (mkStdGen 0)  -- always the same random sequence
+  rand <- getStdGen
+  args <- getArgs
+  let w = if length args > 0 then read (head args) else 100
+  let n = if length args > 1 then read (head (tail args)) else 2000
+  let items = genItems n (randomRs (1, 10) rand)
+  putStrLn $ "w=" ++ show w ++ ", #items = " ++ show n
+  putStrLn.show $ knapsackP w items
+
+genItems :: Int -> [Int] -> [(Int, Int)]
+genItems 0 rs = []
+genItems n (v:w:rs) = (v, w):genItems (n-1) rs
+
+{-
+
+ghc Knapsack.hs -threaded -rtsopts -O2
+
+time ./Knapsack.exe +RTS -N1 -RTS
+time ./Knapsack.exe +RTS -N2 -RTS
+time ./Knapsack.exe +RTS -N4 -RTS
+
+-}
+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell  #-}
+
+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)
+
+
+-- The bag
+data Bag a = Bag [a] deriving (Show,Ord,Read)
+
+instance (Eq a, Ord a) => Eq (Bag a) where
+  (==) (Bag a) (Bag b) = sort a == sort b
+
+items :: Bag a -> [a]
+items (Bag t) = t
+
+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)
+
+data CommutativeMonoid a = CommutativeMonoid {
+    oplus :: a -> a -> a,  -- commutative, associative
+    identity::a           -- the identity of oplus
+    }
+
+-- 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
+data GenericSemiring alg a = GenericSemiring {monoid :: CommutativeMonoid a, 
+                                              algebra :: alg a}
+
+class GenericSemiringStructure alg free uniformer | alg -> free, alg -> uniformer where 
+  freeSemiring :: GenericSemiring alg (Bag free)
+  liftedSemiring :: (Ord c) => GenericSemiring alg a -> alg c -> GenericSemiring alg (Map c a)
+  pairSemiring :: GenericSemiring alg a -> GenericSemiring alg b -> GenericSemiring alg (a,b)
+  shom :: GenericSemiring alg a -> Bag free -> a {- for inefficient impl. -}
+  makeAlgebra :: (CommutativeMonoid m) -> (alg a) -> (m->[a]) -> (a -> m) -> alg m
+  pairAlgebra :: alg a -> alg b -> alg (a,b)
+  freeAlgebra :: alg free
+  hom :: alg a -> 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)
+  foldingAlgebra :: (a -> a -> a) -> a -> uniformer a -> alg a
+
+
+
+-- combinators with optimizations
+
+-- Generator + Filter = Generator
+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
+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
+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
+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 = (>==)
+
+aggregateBy :: forall (alg :: * -> *) free (uniformer :: * -> *) b k.
+         (GenericSemiringStructure alg free uniformer) =>
+             (GenericSemiring alg b -> b) -> GenericSemiring alg b -> b
+aggregateBy = (>=>)
+
+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 
+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 -}
+        
+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'
+infix 6 <.>
+(<.>) :: forall t t1. t -> t1 -> (t, t1)
+(<.>) ok alg = (ok, alg)
+
+
+-- aggregator for generating all candidates passing tests
+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
+
+sumproductBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a.
+                               (GenericSemiringStructure alg free uniformer, Num a) =>
+                               uniformer a -> GenericSemiring alg a
+sumproductBy = genAlgebraFromSemiring (+) 0 (*) 1
+
+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
+
+addIdentity :: forall a. a -> AddIdentity a
+addIdentity a = AddIdentity a
+
+-- max-sum semiring 
+
+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
+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
+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 
+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
+maxsumBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a.
+                           (GenericSemiringStructure alg free uniformer, Ord a, Num a) =>
+                           uniformer (AddIdentity a) -> GenericSemiring alg (AddIdentity a)
+maxsumBy = maxMonoSumBy (+) 0
+
+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
+
+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
+
+
+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
+
+
+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
+
+
+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)
+maxprodBy :: forall free (uniformer :: * -> *) (alg :: * -> *) a.
+                            (GenericSemiringStructure alg free uniformer, Ord a, Num a) =>
+                            uniformer (AddIdentity a) -> GenericSemiring alg (AddIdentity a)
+maxprodBy = maxMonoSumBy (*) 1
+
+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
+
+
+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
+
+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
+
+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
+
+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`
+revOrd :: forall a. a -> RevOrd a
+revOrd a = RevOrd a
+
+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
+
+
+
+
+

src/GTA/Data/BinTree.hs

+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell,TypeSynonymInstances  #-}
+
+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) where
+
+import GTA.Core
+import GTA.Util.GenericSemiringStructureTemplate
+import Data.List
+
+-- leaf-valued binary tree
+data LVTree a = NodeLV (LVTree a) (LVTree a)
+              | LeafLV a
+                deriving (Eq, Ord, Read)
+
+-- automatic generation of things necessary for GTA framework
+genAllDecl ''LVTree
+
+-- renaming
+type LVTreeSemiring a s = GenericSemiring (LVTreeAlgebra a) s
+
+{-
+-- generalized version of the matrix chain DP algorithm O(n^3)
+generates a bag of trees from a list.
+The left-to-right traversal of each tree is equivalent to the input list.
+-}
+lvtrees :: [a] -> LVTreeSemiring a s -> s
+lvtrees x bts = head (head (lvtrees' x bts))
+
+lvtrees' :: [a] -> LVTreeSemiring a s -> [[s]]
+lvtrees' x (GenericSemiring{..}) = 
+    let CommutativeMonoid {..} = monoid
+        LVTreeAlgebra {..} = algebra
+        ls = map f x
+        bigOplus = foldr oplus identity
+        f a = leafLV a 
+        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))
+                hs = map reverse (transpose ts)
+                ns = zipWith mrg hs vs
+            in ns:ts
+        mrg h v = bigOplus (concat (zipWith f' h v))
+    in foldl merge [ls] [1..(n-1)]
+
+
+-- binary tree with different types for nodes and leaves
+data BinTree n l = BinNode n (BinTree n l) (BinTree n l)
+                 | BinLeaf l
+             deriving (Eq, Ord, Read)
+
+
+genAllDecl ''BinTree
+
+{-
+{- this algebra can be generated automatically from BinTree -}
+genAlgebraDecl ''BinTree
+{-
+data BinTreeAlgebra n l a = 
+  BinTreeAlgebra {
+    binNode :: n -> a -> a -> a,
+    binLeaf :: l -> a
+  }
+-}
+genMapFunctionsDecl ''BinTree
+-- -- maps to a coherent data
+-- data BinTreeMapFs n l a = BinTreeMapFs {
+--         binNodeF :: (n -> a),
+--         binLeafF :: (l -> a)
+--       }
+
+{- this instance can be generated automatically from BinTree -}
+genInstanceDecl ''BinTree
+
+-- the generic semiring structure of BinTreeALgebra n l
+-- instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where
+--   freeAlgebra = BinTreeAlgebra {..} where
+--     binNode = BinNode
+--     binLeaf = BinLeaf
+--   hom (BinTreeAlgebra {..}) = h
+--     where
+--       h (BinNode a l r) = binNode a (h l) (h r)
+--       h (BinLeaf a) = binLeaf a
+--   pairAlgebra bt1 bt2 = BinTreeAlgebra {..} 
+--     where
+--       binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2)
+--       binLeaf a = (binLeaf1 a, binLeaf2 a)
+--       (binLeaf1, binNode1) = let BinTreeAlgebra {..} = bt1 in (binLeaf, binNode)
+--       (binLeaf2, binNode2) = let BinTreeAlgebra {..} = bt2 in (binLeaf, binNode)
+--   makeAlgebra (CommutativeMonoid {..}) bt frec fsingle = BinTreeAlgebra {..}
+--     where  
+--     binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r]
+--     binLeaf a = fsingle (binLeaf' a)
+--     (binLeaf', binNode') = let BinTreeAlgebra {..} = bt in (binLeaf, binNode)
+--   foldingAlgebra op iop (BinTreeMapFs {binNodeF=(binNodeF1),binLeafF=(binLeafF1)}) = BinTreeAlgebra {..}
+--     where
+--     binNode a l r = binNodeF1 a `op` l `op` r
+--     binLeaf a = binLeafF1 a
+
+-}
+
+-- renaming
+type BinTreeSemiring n l a = GenericSemiring (BinTreeAlgebra n l) a
+
+
+-- BinTree-semiring for counting
+count :: Num a => BinTreeSemiring n l a
+count = sumproductBy (BinTreeMapFs {binLeafF = const 1, binNodeF = const 1})
+
+-- shotcuts to maxsum of marked trees
+markedT :: forall a. Num a =>
+                          BinTreeMapFs (Bool, a) (Bool, a) (AddIdentity a)
+markedT = BinTreeMapFs {binNodeF=f, binLeafF=f}
+  where f (m,a) = AddIdentity (if m then  a else 0)
+
+maxsum :: (Num a, Ord a) => BinTreeSemiring (Bool, a) (Bool, a) (AddIdentity a)
+maxsum = maxsumBy markedT
+
+maxsumsolution :: (Num a, Ord a) => BinTreeSemiring (Bool, a) (Bool, a) (AddIdentity a, Bag (BinTree (Bool, a) (Bool, a)))
+maxsumsolution = maxsumsolutionBy markedT
+
+-- predicate for rooted suBinTrees (i.e., those including the original root)
+data RtStClass = Rtd | Emp | NG deriving (Show, Eq, Ord, Read)
+
+rtst :: forall t t1. BinTreeAlgebra (Bool, t1) (Bool, t) RtStClass
+rtst = BinTreeAlgebra {..}
+  where
+  binNode (True, _) l r = case (l, r) of
+                            (Rtd, Rtd) -> Rtd
+                            (Rtd, Emp) -> Rtd
+                            (Rtd, NG)  -> NG
+                            (Emp, Rtd) -> Rtd
+                            (Emp, Emp) -> Rtd
+                            (Emp, NG)  -> NG
+                            (NG , Rtd) -> NG
+                            (NG , Emp) -> NG
+                            (NG , NG)  -> NG
+  binNode (False, _) l r =  case (l, r) of
+                              (Rtd, Rtd) -> NG
+                              (Rtd, Emp) -> NG
+                              (Rtd, NG)  -> NG
+                              (Emp, Rtd) -> NG
+                              (Emp, Emp) -> Emp
+                              (Emp, NG)  -> NG
+                              (NG , Rtd) -> NG
+                              (NG , Emp) -> NG
+                              (NG , NG)  -> NG
+  binLeaf (m, _) = if m then Rtd else Emp
+
+
+-- predicate for all suBinTrees
+data StClass = RtdST  -- suBinTree including the root
+             | IsoST  -- isolated suBinTree
+             | Empty  -- empty
+             | Other  -- other NGs
+               deriving (Show, Eq, Ord, Read)
+
+st :: forall t t1. BinTreeAlgebra (Bool, t1) (Bool, t) StClass
+st = BinTreeAlgebra {..} where
+  binNode (True, _) l r =  case (l, r) of
+                             (RtdST, RtdST) -> RtdST
+                             (RtdST, IsoST) -> Other
+                             (RtdST, Empty) -> RtdST
+                             (RtdST, Other) -> Other
+                             (IsoST, RtdST) -> Other
+                             (IsoST, IsoST) -> Other
+                             (IsoST, Empty) -> Other
+                             (IsoST, Other) -> Other
+                             (Empty, RtdST) -> RtdST
+                             (Empty, IsoST) -> Other
+                             (Empty, Empty) -> RtdST
+                             (Empty, Other) -> Other
+                             (Other, RtdST) -> Other
+                             (Other, IsoST) -> Other
+                             (Other, Empty) -> Other
+                             (Other, Other) -> Other
+  binNode (False, _) l r =  case (l, r) of
+                              (RtdST, RtdST) -> Other
+                              (RtdST, IsoST) -> Other
+                              (RtdST, Empty) -> IsoST
+                              (RtdST, Other) -> Other
+                              (IsoST, RtdST) -> Other
+                              (IsoST, IsoST) -> Other
+                              (IsoST, Empty) -> Other
+                              (IsoST, Other) -> Other
+                              (Empty, RtdST) -> IsoST
+                              (Empty, IsoST) -> IsoST
+                              (Empty, Empty) -> Empty
+                              (Empty, Other) -> Other
+                              (Other, RtdST) -> Other
+                              (Other, IsoST) -> Other
+                              (Other, Empty) -> Other
+                              (Other, Other) -> Other
+  binLeaf (m, _) = if m then RtdST else Empty
+
+
+
+{-
+  This is BinTreeSemiring-polymorphic LVTreeSemiring.
+  We can use this kind of A-semirnig-polymorphic B-semiring to
+   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]
+
+
+---generators
+{-
+generating a bag of trees from a list.
+The left-to-right traversal of each tree is equivalent to the input list, 
+ignoring the assigned marks.
+-}
+assignTrees :: [b] -> [c] -> [a] -> BinTreeSemiring c (b, a) s -> s
+assignTrees msl msn x = lvtrees x >=< assignTrans msl msn
+
+-- polymorphic generator for all selections
+selects :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
+selects t bts = selects' t
+  where
+    BinTreeAlgebra {..} = algebra bts
+    CommutativeMonoid {..} = monoid bts
+    selects' (BinNode a l r) = 
+      let l' = selects' l; r' = selects' r 
+      in binNode (True, a) l' r' `oplus` binNode (False, a) l' r'
+    selects' (BinLeaf a) = (binLeaf (True, a)) `oplus` (binLeaf (False, a))  
+
+
+subtreeSelectsWithRoot :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
+subtreeSelectsWithRoot t = selects t >== (/=NG)<.>rtst
+subtreeSelects :: BinTree n l -> BinTreeSemiring (Bool,n) (Bool,l) a -> a
+subtreeSelects t = selects t >== (/=Other)<.>st
+

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) where
+
+import GTA.Core
+import GTA.Util.GenericSemiringStructureTemplate
+import GTA.Data.BinTree (BinTree (..))
+import Control.Parallel
+
+{- example of the usual semirings -}
+
+-- join list = associative binary tree
+data JoinList a = Times (JoinList a) (JoinList a)
+                | Single a
+                | Nil
+--             deriving (Show, Eq, Ord, Read)
+
+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)
+
+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 (\(x, s)->(joinize x, 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)
+
+
+-- 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
+inits :: [a] -> Semiring a s -> s
+inits = initsJ sequentialJoinListHom.joinize
+tails :: [a] -> Semiring a s -> s
+tails = tailsJ sequentialJoinListHom.joinize
+subs :: [a] -> Semiring a s -> s
+subs = subsJ sequentialJoinListHom.joinize
+assigns :: [m] -> [a] -> Semiring (m, a) s -> s
+assigns ms = assignsJ sequentialJoinListHom ms.joinize
+
+segsJ :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
+segsJ h x (GenericSemiring {..}) = 
+    let (s, _, _, _) = segs' x
+    in s `oplus` nil 
+    where segs' = h (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 :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
+initsJ h x (GenericSemiring {..}) = 
+    let (i, _) = inits' x
+    in nil `oplus` i
+    where inits' = h (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 :: (forall b s.JoinListAlgebra b s -> JoinList b -> s) -> JoinList a -> Semiring a s -> s
+tailsJ h x (GenericSemiring {..}) = 
+    let (t, _) = tails' x
+    in t `oplus` nil
+    where tails' = h (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 :: (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})
+          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})
+          single' a = foldr oplus identity [single (m, a) | m <- ms]
+          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
+    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
+mapJ :: forall b a. (b -> a) -> JoinListMapFs b a
+mapJ f = JoinListMapFs {..} where singleF = f
+
+-- JoinList-semiring for counting
+count :: Num a => Semiring b a
+count = sumproductBy (JoinListMapFs {singleF = const 1})
+
+
+{- simplified aggregators -}
+
+maxsum :: (Ord a, Num a) => Semiring a (AddIdentity a)
+maxsum = maxsumBy (JoinListMapFs {singleF = addIdentity})
+
+maxsumsolution :: (Ord a, Num a) => Semiring a (AddIdentity a, Bag (JoinList a))
+maxsumsolution = maxsumsolutionBy (JoinListMapFs {singleF = addIdentity})
+
+maxsumWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a)
+maxsumWith f = maxsumBy (mapJ (addIdentity.f))
+
+maxsumKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b ([AddIdentity a])
+maxsumKWith k f = maxsumKBy k (mapJ (addIdentity.f))
+
+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)) 
+
+maxsumsolutionXWith :: (Ord a, Num a) =>
+                       Semiring c b -> (c -> a) -> Semiring c (AddIdentity a, b)
+maxsumsolutionXWith s f = maxsumsolutionXBy s (mapJ (addIdentity.f))
+
+maxsumsolutionWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a, Bag (JoinList b))
+maxsumsolutionWith f = maxsumsolutionBy (mapJ (addIdentity.f))
+
+maxsumsolutionKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b [(AddIdentity a, Bag (JoinList b))]
+maxsumsolutionKWith k f = maxsumsolutionKBy k (mapJ (addIdentity.f))
+
+maxprodWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a)
+maxprodWith f = maxprodBy (mapJ (addIdentity.f)) 
+
+maxprodKWith :: (Ord a, Num a) => Int -> (b -> a) -> Semiring b ([AddIdentity a])
+maxprodKWith k f = maxprodKBy k (mapJ (addIdentity.f))
+
+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))
+maxprodsolutionXWith :: (Ord a, Num a) =>
+                       Semiring c b -> (c -> a) -> Semiring c (AddIdentity a, b)
+maxprodsolutionXWith s f = maxprodsolutionXBy s (mapJ (addIdentity.f))
+
+maxprodsolutionWith :: (Ord a, Num a) => (b -> a) -> Semiring b (AddIdentity a, Bag (JoinList b))
+maxprodsolutionWith f = maxprodsolutionBy (mapJ (addIdentity.f))
+
+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
+
+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
+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

src/GTA/Util/GenericSemiringStructureTemplate.hs

+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,TemplateHaskell  #-}
+
+module GTA.Util.GenericSemiringStructureTemplate (genAlgebraDecl, genMapFunctionsDecl, genInstanceDecl, genAllDecl) where
+
+import Language.Haskell.TH
+import GTA.Util.TypeInfo 
+import Data.Char
+{-
+reference: 
+ http://www.haskell.org/haskellwiki/Template_haskell/Instance_deriving_example
+-}
+
+{- exported functions -}
+genAlgebraDecl :: Name -> Q [Dec]
+genAlgebraDecl typName =
+  do (typeName,typeParams,constructors) <- typeInfo typName
+     alg <- genAlgebraRecord typeName typeParams constructors
+     return ([alg])
+
+genMapFunctionsDecl :: Name -> Q [Dec]
+genMapFunctionsDecl typName =
+  do (typeName,typeParams,constructors) <- typeInfo typName
+     alg <- genMapFunctionsRecord typeName typeParams constructors
+     return ([alg])
+
+genInstanceDecl :: Name -> Q [Dec]
+genInstanceDecl typName =
+  do (typeName,typeParams,constructors) <- typeInfo typName
+     inst <- genSemiringInstance typeName typeParams constructors
+     return ([inst])
+
+genAllDecl :: Name -> Q [Dec]
+genAllDecl typName =
+  do alg <- genAlgebraDecl typName
+     mf <- genMapFunctionsDecl typName
+     inst <- genInstanceDecl typName
+     return (alg ++ mf ++ inst)
+
+{-
+Given a data type like
+ data BTree a = Node a (BTree a) (BTree a)
+              | Leaf a
+, this generates a record type corresponding to the algebra like
+ data BTreeAlgebra b a = 
+   BTreeAlgebra {
+     node :: b -> a -> a -> a,
+     leaf :: b -> a
+   }
+.
+-}
+genAlgebraRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genAlgebraRecord typeName typeParams constructors = 
+  let a = mkName "a"
+      newParams = typeParams++[PlainTV a]
+      dataName = algebraName typeName
+      funs = map genFun constructors -- functions corresponding to constructors
+      con = recC dataName funs -- the constructor = the name
+      genFun (name, params) = 
+        varStrictType (funcName name) 
+        (strictType notStrict (arrowConcat (map (\(VarT a) -> varT a) (replace freeType (VarT a) (map (\(_, t) -> t) params ++[VarT a])))))
+      freeType = genFreeType typeName typeParams
+  in dataD (cxt []) dataName newParams [con] []
+
+{-
+data BTreeMapFs b b' = BTreeMapFs {
+         nodeF :: (b -> b'),
+         leafF :: (b -> b')
+       }
+This is a set of functions to make types of values the same.
+-}
+genMapFunctionsRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genMapFunctionsRecord typeName typeParams constructors = 
+  let a = mkName "a"
+      newParams = typeParams++[PlainTV a]
+      mapName = mapFunctionsName typeName
+      funs = map genFun constructors' -- functions corresponding to constructors
+      con = recC mapName funs -- the constructor = the name
+      funcName' = mfFuncName . funcName
+      constructors' = filter (\(_, x) -> length x > 0) (map dropFreeType constructors)
+      dropFreeType (name, params) = (name, filter (/=freeType) (map (\(_, t) -> t) params))
+      genFun (name, params) = 
+        varStrictType (funcName' name) 
+        (strictType notStrict (mkTupleType (map (\(VarT b) -> appT (appT arrowT (varT b)) (varT a)) params)))
+      freeType = genFreeType typeName typeParams
+  in dataD (cxt []) mapName newParams [con] []
+     
+mkTupleType :: [TypeQ] -> TypeQ
+mkTupleType [a] = a
+mkTupleType x = foldl appT (tupleT (length x)) x
+{-
+  instance GenericSemiringStructure (BTreeAlgebra b) (BTree b) (BTreeMapFunctions b) where
+-}
+genSemiringInstance :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genSemiringInstance typeName typeParams constructors = 
+  let className = mkName "GenericSemiringStructure" 
+      appfold e = foldl appT e . map (\(PlainTV a) -> varT a) 
+      instanceType = appT (appT (appT (conT className) (appfold (conT dataName) typeParams)) (appfold (conT typeName) typeParams)) (appfold (conT mapName) typeParams)
+      dataName = algebraName typeName
+      mapName = mapFunctionsName typeName
+--      funcs = [genBagFreeAlgebra typeName typeParams constructors,
+--               genLiftedAlgebra typeName typeParams constructors,
+--               genHom typeName typeParams constructors]
+      funcs = [genFreeAlgebra typeName typeParams constructors,
+               genHom typeName typeParams constructors,
+               genPairAlgebra typeName typeParams constructors,
+               genMakeAlgebra typeName typeParams constructors,
+               genFoldingAlgebra typeName typeParams constructors]
+  in instanceD (cxt []) instanceType funcs
+
+{-
+  freeAlgebra = BTreeAlgebra {..} where
+     node = Node
+     leaf = Leaf
+-}
+genFreeAlgebra :: forall t t1. Name -> t -> [(Name, t1)] -> DecQ
+genFreeAlgebra typeName _ constructors = 
+  let
+    freeAlgebraName = (mkName "freeAlgebra")
+    fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
+    e = recConE (algebraName typeName) fieldEs
+    decls = map genFunDecl constructors
+    genFunDecl (n, _) = funD (funcName n) [clause [] (normalB (conE n)) []]
+  in funD freeAlgebraName [clause [] (normalB e) decls]
+
+{-
+  pairAlgebra bt1 bt2 = BTreeAlgebra {..} 
+    where
+      node a (l1, l2) (r1, r2) = (node1 a l1 r1, node2 a l2 r2)
+      leaf a = (leaf1 a, leaf2 a)
+      (leaf1, node1) = let BTreeAlgebra {..} = bt1 in (leaf, node)
+      (leaf2, node2) = let BTreeAlgebra {..} = bt2 in (leaf, node)
+-}
+genPairAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genPairAlgebra typeName typeParams constructors = 
+  let
+    alg1 = mkName "algebra1"
+    alg2 = mkName "algebra2"
+    vps = map varP [alg1, alg2]
+    fs = map (\(n, _)->funcName n) constructors
+    binds = [recBind (algebraName typeName) fs (varE alg1) (name 1),
+             recBind (algebraName typeName) fs (varE alg2) (name 2)]
+    name i = mkName . (++show i) . nameBase
+    bindExp ve = ve
+    bindPat a = tupP [varP (name 1 a), varP (name 2 a)]
+    newAlgebraName = (mkName "pairAlgebra")
+    genBody _ n' pbs = tupE [foldl1 appE (varE (name 1 n'):vars 1), foldl1 appE (varE (name 2 n'):vars 2)]
+      where
+        varnames f = map (\(b, VarT a) -> case b of Just (VarT c) -> f c
+                                                    otherwise -> a) pbs
+        vars i = map varE (varnames (name i))
+  in genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody
+
+{-
+  makeAlgebra (CommutativeMonoid {..}) bt frec fsingle = BTreeAlgebra {..}
+    where  
+    node a l r = foldr oplus identity [fsingle (node' a l' r') | l' <- frec l, r' <- frec r]
+    leaf a = fsingle (leaf' a)
+    (leaf', node') = let BTreeAlgebra {..} = bt in (leaf, node)
+
+-}
+genMakeAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genMakeAlgebra typeName typeParams constructors = 
+  let
+    m = mkName "m"
+    alg = mkName "alg"  
+    frec = mkName "frec"
+    fsingle = mkName "fsingle"
+    vps = map varP [m, alg, frec, fsingle]
+    fs = map (\(n, _)->funcName n) constructors
+    binds = [recBind (algebraName typeName) fs (varE alg) name,
+             monoidBind (varE m)]
+    name = mkName . (++"A") . nameBase
+    bindExp ve = appE (varE frec) ve
+    bindPat a = varP a
+    newAlgebraName = (mkName "makeAlgebra")
+    genComprBody _ n' pbs = appE (varE fsingle) (foldl1 appE (varE (name n'):vars))
+      where vars = map (\(b, VarT a) -> case b of Just (VarT c) -> varE c
+                                                  otherwise -> varE a) pbs
+  in genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody
+
+{-
+  foldingAlgebra op (BTreeMapFs {nodeF=(nodeF1),leafMF=(leafF1)}) = BTreeAlgebra {..}
+    where
+    node a l r = nodeF1 a `op` l `op` r
+    leaf a = leafF1 a
+-}
+genFoldingAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genFoldingAlgebra typeName typeParams constructors = 
+  let
+    mf = mkName "mf"
+    op = mkName "op"
+    iop = mkName "iop"
+    vps = map varP [op, iop, mf]
+    constructors' = filter hasNonRec constructors
+    hasNonRec (_, ps) = length (filter (\(_, t) -> t /=freeType) ps) > 0
+    fs = map (\(n, _)->mfFuncName(funcName n)) constructors'
+    binds = [recBind (mapFunctionsName typeName) fs (varE mf) id]
+    freeType = genFreeType typeName typeParams
+    newAlgebraName = (mkName "foldingAlgebra")
+    funcs _ n' pbs = let 
+        nonrecs = map (\(b, VarT _) -> case b of Just (VarT _) -> 0
+                                                 otherwise -> 1) pbs
+        ids = tail(scanl (+) 0 nonrecs)
+        f 0 _ a = Left a
+        f 1 i b = Right (name i (mfFuncName n'), b)
+        in zipWith3 f nonrecs ids pbs        
+    name i =  mkName . (++show i) . nameBase
+    genVarbinds n n' pbs = 
+        let funs = funcs n n' pbs
+            ns = map (\(Right (n, _)) -> varP n) (filter fr funs)
+            fr (Left _) = False
+            fr (Right _) = True
+        in if length ns == 0 then [] else [valD (tupP ns) (normalB (varE (mfFuncName n'))) []]
+    genBody n n' pbs = if pbs == [] then varE iop else foldl1 (\a b -> appE (appE (varE op) a) b) vars
+      where
+        funs = funcs n n' pbs
+        vars = map f funs
+        f (Left (_, VarT a)) = varE a
+        f (Right (fn, (_, VarT a))) = appE (varE fn) (varE a)
+  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
+
+
+
+{-  
+hom (BTreeBAlgebra {..}) = h
+  where
+    h (NodeB a l r) = nodeB a (h l) (h r)
+    h (LeafB a) = leafB a
+-}
+genHom :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
+genHom typeName typeParams constructors = 
+  let
+    fs = map (\(n, _)->funcName n) constructors
+    vps = [recPat (algebraName typeName) fs id]
+    freeType = genFreeType typeName typeParams
+    decls = [funD h (map genClause constructors)]
+    h = mkName "h"
+    genClause (n, ps) = let
+      n' = funcName n
+      ts = map (\(_, t) -> t) ps
+      pbs = zipWith mkpb ts (newVars "rv")
+      mkpb t v = if t == freeType then (Just (), v) else (Nothing, t)
+      pats = [conP n (map (\(_, VarT a) -> varP a) pbs)]
+      subes = map (\(b, VarT a) -> case b of Just () -> appE (varE h) (varE a)
+                                             otherwise -> varE a) pbs
+      b = foldl appE (varE n') subes
+      in clause pats (normalB b) []
+  in funD (mkName "hom") [clause vps (normalB (varE h)) decls]
+
+{-
+TODO: this function has been split into several parts. write comments!
+
+e.g., to generate the following,
+
+  liftedAlgebra bts bt = BTreeAlgebra {..}
+    where  
+      node a l r = 
+        foldr oplus identity [singleton (nodebt a kll krr) (nodebt' a vll vrr) | (kll, vll) <- assocs l, (krr, vrr) <- assocs r]
+      leaf a = singleton (leafbt a) (leafbt' a)
+      CommutativeMonoid {..} = mapMonoid (monoid bts)
+      (leafbt, nodebt) = let BTreeAlgebra {..} = bt in (leaf, node)
+      (leafbt', nodebt') = let BTreeAlgebra {..} = algebra bts in (leaf, node)
+
+the function arguments are
+ - (typeName, typeParams, constructors) is of typeInfo ''BTree
+ - binds is a list of valDs for    
+      CommutativeMonoid {..} = mapMonoid (monoid bts)
+      (leafbt, nodebt) = let BTreeAlgebra {..} = bt in (leaf, node)
+      (leafbt', nodebt') = let BTreeAlgebra {..} = algebra bts in (leaf, node)
+ - newAlgebraName is 'liftedAlgebra'
+ - vps is a list of argument patterns of the 'liftedAlgebra', i.e., [bts, bt] 
+ - bindExp generates expressions (RHS of <-) of binds in the comprehension, 
+   i.e., bindExp v = assocs v
+ - bindPat generates patterns (LHS of <-) of binds in the comprehension,
+   i.e., bindPat r = (kr, vr)
+ - genComprBody generates the body of the comprehention from 
+     n   ... the constructor name
+     n'  ... the function name corresponding to the constructor
+     pbs ... a list of (Maybe Type, Type) generated from the constructor's type 
+               Here, each value of Type is of VarT x.
+               If the variable has the same type as the data structure,
+                the first part is Just (VarT y) 
+                s.t. a bind "bindPat y <- bindExp x" is generated.
+               Otherwise it is Nothing.
+               For Node of BTree, pbs = [(Nothing, VarT a), 
+                                         (Just (VarT ll), VarT l),
+                                         (Just (VarT rr), VarT r)]
+-}
+genAlgebraDec :: forall t.
+                     Name
+                     -> [TyVarBndr]
+                     -> [(Name, [(t, Type)])]
+                     -> [DecQ]
+                     -> Name
+                     -> [PatQ]
+                     -> (ExpQ -> ExpQ)
+                     -> (Name -> PatQ)
+                     -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
+                     -> DecQ
+genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody = 
+  let
+    genVarbinds _ _ _ = []
+    genBody n n' pbs =
+          if and (map ((==Nothing).fst) pbs) 
+          then -- has no recursive position 
+              genComprBody n n' pbs                    
+          else -- has recursive positions
+              let 
+                  bigOp = foldl1 appE (map (varE.mkName) ["foldr", "oplus", "identity"])
+                  
+                  varbinds = map bind (filter ((/=Nothing).fst) pbs)
+                  bind (Just(VarT a),VarT b) = bindS (bindPat a) (bindExp (varE b))
+                  compr = compE (varbinds++[noBindS (genComprBody n n' pbs)])
+              in appE bigOp compr
+  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
+
+genAlgebraDec' :: forall t.
+                     Name
+                        -> [TyVarBndr]
+                        -> [(Name, [(t, Type)])]
+                        -> [DecQ]
+                        -> Name
+                        -> [PatQ]
+                        -> (ExpQ -> ExpQ)
+                        -> (Name -> PatQ)
+                        -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
+                        -> DecQ
+genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody = 
+  let genVarbinds _ _ pbs = map bind (filter ((/=Nothing).fst) pbs)
+        where bind (Just(VarT a),VarT b) = valD (bindPat a) (normalB (bindExp (varE b))) []
+  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
+
+genAlgebraDec'' :: forall t.
+                      Name
+                          -> [TyVarBndr]
+                          -> [(Name, [(t, Type)])]
+                          -> [DecQ]
+                          -> Name
+                          -> [PatQ]
+                          -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
+                          -> (Name -> Name -> [(Maybe Type, Type)] -> [DecQ])
+                          -> DecQ
+genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds = 
+    let fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
+        e = recConE (algebraName typeName) fieldEs
+        freeType = genFreeType typeName typeParams
+        decls = map genFunDecl constructors ++ binds
+        genFunDecl (n, ps) = 
+          let n' = funcName n
+              ts = map (\(_, t) -> t) ps
+              pbs = zipWith3 mkpb ts (newVars "rv") (newVars "rvi")
+              mkpb t v vv = if t == freeType then (Just vv, v) else (Nothing, t)
+              pats = map (\(_, VarT a) -> varP a) pbs
+              b = genBody n n' pbs
+              varbinds = genVarbinds n n' pbs
+          in funD n' [clause pats (normalB b) varbinds]
+    in funD newAlgebraName [clause vps (normalB e) decls]
+
+replace :: forall b. Eq b => b -> b -> [b] -> [b]
+replace a b x = map (\c -> if c == a then b else c) x
+
+arrowConcat :: [TypeQ] -> TypeQ
+arrowConcat = foldr1 (\v x -> appT (appT arrowT v) x)
+
+funcName :: Name -> Name
+funcName = mkName . unCapalize . nameBase
+
+unCapalize :: [Char] -> [Char]
+unCapalize (x:y) = (toLower x):y
+
+algebraName :: Name -> Name
+algebraName typeName = mkName (nameBase typeName++"Algebra")
+
+mapFunctionsName :: Name -> Name
+mapFunctionsName typeName = mkName (nameBase typeName++"MapFs")
+
+mfFuncName :: Name -> Name
+mfFuncName = mkName . (++"F") . nameBase 
+
+monoidBind :: ExpQ -> DecQ
+monoidBind e = recBind (mkName "CommutativeMonoid") [mkName "oplus", mkName "identity"] e id
+
+recBind :: Name -> [Name] -> ExpQ -> (Name -> Name) -> DecQ
+recBind n fs e f = valD (recPat n fs f) (normalB e) []
+
+recPat :: Name -> [Name] -> (Name -> Name) -> PatQ
+recPat n fs f = recP n (genWildcardFieldPat f fs)
+
+genFreeType :: Name -> [TyVarBndr] -> Type
+genFreeType typeName typeParams = foldl1 AppT (ConT typeName:typeParams'')
+  where typeParams'' = map (\(PlainTV a) -> VarT a) typeParams
+
+genWildcardFieldExp :: [Name] -> [Q (Name, Exp)]
+genWildcardFieldExp = map (\n -> fieldExp n (varE n)) 
+
+genWildcardFieldPat :: (Name -> Name) -> [Name] -> [FieldPatQ]
+genWildcardFieldPat f = map (\n -> fieldPat n (varP (f n))) 
+
+newVars :: [Char] -> [Type]
+newVars s = g 0 where g i = VarT (mkName (s ++ show i)) : g (i+1)
+

src/GTA/Util/TypeInfo.hs

+{-
+
+copied from: 
+  http://haskell.1045720.n5.nabble.com/Deriving-Read-with-Template-Haskell-Re-automatic-instances-for-pretty-printing-and-parsing-td3197647.html
+
+modified.
+
+-}
+
+
+{-|
+  Observing a structure of a datatype in a uniform way no matter
+  whether it was defined in infix, prefix or record form.
+
+  This code is based on the @Derive@ module from the SYB3 code distribution,
+  (C) 2005, Ralf Laemmel and Simon Peyton Jones, see
+  <http://homepages.cwi.nl/~ralf/syb3/code.html>.
+-}
+
+module GTA.Util.TypeInfo (TypeInfo, typeInfo, simpleName) where
+
+import Language.Haskell.TH
+
+{-|
+  The first part is the name, the second - a list of type parameters,
+  the third - a list of constructors. For each constructor we have a name
+  and a list describing constructor fields.
+-}
+--type TypeInfo = (Name, [Name], [(Name, [(Maybe Name, Type)])])
+type TypeInfo = (Name, [TyVarBndr], [(Name, [(Maybe Name, Type)])])
+
+typeInfo :: Name -> Q TypeInfo
+typeInfo name = do
+  info' <- reify name
+  case info' of
+    TyConI d -> typeInfo' ((return d) :: Q Dec)
+    _        -> error ("typeInfo: can't be used on anything but a type " ++
+                       "constructor of an algebraic data type")
+
+typeInfo' :: DecQ -> Q TypeInfo
+typeInfo' m =
+     do d <- m
+        case d of
+           d@(DataD _ _ _ _ _) ->
+            return $ (name d, paramsA d, termsA d)
+           d@(NewtypeD _ _ _ _ _) ->
+            return $ (name d, paramsA d, termsA d)
+           _ -> error ("typeInfo': not a data type declaration: " ++ show d)
+
+     where
+        paramsA (DataD _ _ ps _ _) = ps
+        paramsA (NewtypeD _ _ ps _ _) = ps
+
+        termsA (DataD _ _ _ cs _) = map termA cs
+        termsA (NewtypeD _ _ _ c _) = [ termA c ]
+
+        termA (NormalC c xs)        = (c, map (\x -> (Nothing, snd x)) xs)
+        termA (RecC c xs)           = (c, map (\(n, _, t) -> (Just n, t)) xs)
+        termA (InfixC t1 c t2)      = (c, [(Nothing, snd t1), (Nothing, snd t2)])
+
+        name (DataD _ n _ _ _)      = n
+        name (NewtypeD _ n _ _ _)   = n
+        name d                      = error $ show d
+
+{-|
+  Apply 'nameBase' to the name.
+-}
+simpleName :: Name -> Name
+simpleName = mkName . nameBase
+
+{-
+   -- this breaks names like :$
+   let s = nameBase nm
+   in case dropWhile (/=':') s of
+        []          -> mkName s
+        _:[]        -> mkName s
+        _:t         -> mkName t
+-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main where
+import GTA.Data.JoinList
+import GTA.Core hiding (items)
+import Test.Framework  ( defaultMain, testGroup )
+import Test.Framework.Providers.HUnit ( testCase ) 
+import Test.HUnit ( (@=?) )
+
+tests = [testGroup "Simple Test Group" [
+                        testCase "simple test" test_knapsack
+                       ]]
+
+test_knapsack = knapsack w items @=? AddIdentity(40)
+
+main :: IO ()
+main = flip catch print $ defaultMain tests
+
+weightlimit w = (<=w) <.> ws
+  where ws = JoinListAlgebra{..} where 
+           x1 `times` x2  = (   x1 +    x2) `min` (w+1)
+           single i  = getWeight i `min` (w+1)
+           nil = 0
+
+knapsack w items = 
+  subs items 
+    >== weightlimit w
+    >=> maxsumWith getValue
+
+getWeight (w, v) = w
+getValue (w, v) = v
+items = [(1, 10), (4, 20), (2,30)]
+w = 5