```{-# 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

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)

-- stupid joinize function
joinize :: forall a. [a] -> JoinList a
joinize [] = Nil
joinize [a] = Single a
joinize x = let (x1,x2) = splitAt d x
n = length x
d = (n `div` 2)
in Times (joinize x1) (joinize x2)

-- stupid dejoinize function
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

--- useful functions to design generators: constructors of bags of lists
crossConcat :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a)
crossConcat = times (algebra freeSemiring)

bagOfSingleton :: a -> Bag (JoinList a)
bagOfSingleton = single (algebra freeSemiring)

bagOfNil :: Bag (JoinList a)
bagOfNil =  nil (algebra freeSemiring)

emptyBag :: Bag (JoinList a)
emptyBag = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a))
in identity monoid

bagUnion :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a)
bagUnion = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a))
in oplus monoid

```