module GTA.Data.ConsList (ConsList(Cons, Nil), ConsListAlgebra(ConsListAlgebra), cons, nil, consize, deconsize, segs, inits, tails, subs, assigns, assignsBy, paths, mapC, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, crossCons, emptyBag, bagOfNil, bagUnion, ConsSemiring, foldr') where
import GTA.Core
import GTA.Util.GenericSemiringStructureTemplate
import GTA.Data.BinTree (BinTree (..))
data ConsList a = Cons a (ConsList a)
| Nil
genAllDecl ''ConsList
consize :: forall a. [a] -> ConsList a
consize = foldr Cons Nil
deconsize :: forall a. ConsList a -> [a]
deconsize = hom (ConsListAlgebra{cons=(:),nil=[]})
instance Show a => Show (ConsList a) where
showsPrec d x = showsPrec d (deconsize x)
instance Read a => Read (ConsList a) where
readsPrec d x = map (\(y, s)->(consize y, s)) (readsPrec d x)
instance Eq a => Eq (ConsList a) where
(==) x y = deconsize x == deconsize y
instance Ord a => Ord (ConsList a) where
compare x y = compare (deconsize x) (deconsize y)
foldr' :: forall a s.(a -> s -> s) -> s -> ConsListAlgebra a s
foldr' f e = ConsListAlgebra {cons = f, nil = e}
type ConsSemiring a s= GenericSemiring (ConsListAlgebra a) s
segs :: [a] -> ConsSemiring a s -> s
segs x (GenericSemiring {..}) =
let (s, i) = foldr cons' nil' x
in i `oplus` s
where cons' a (s, i) = (i `oplus` s, cons a (nil `oplus` i))
nil' = (nil, identity)
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
inits :: [a] -> ConsSemiring a s -> s
inits x (GenericSemiring {..}) = foldr cons' nil x
where cons' a i = nil `oplus` cons a i
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
tails :: [a] -> ConsSemiring a s -> s
tails x (GenericSemiring {..}) =
let (t, _) = foldr cons' nil' x
in t
where cons' a (t, w) = let aw = cons a w
in ( aw `oplus` t, aw)
nil' = (nil, nil)
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
subs :: [a] -> ConsSemiring a s -> s
subs x (GenericSemiring {..}) = foldr cons' nil x
where cons' a y = cons a y `oplus` y
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
assigns :: [m] -> [a] -> ConsSemiring (m,a) s -> s
assigns ms x (GenericSemiring {..}) = foldr cons' nil x
where cons' a y = foldr oplus identity [cons (m, a) y | m <- ms]
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
assignsBy :: (a -> [m]) -> [a] -> ConsSemiring (m,a) s -> s
assignsBy f x (GenericSemiring {..}) = foldr cons' nil x
where cons' a y = foldr oplus identity [cons (m, a) y | m <- f a]
ConsListAlgebra {..} = algebra
CommutativeMonoid {..} = monoid
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
mapC :: forall b a. (b -> a) -> ConsListMapFs b a
mapC f = ConsListMapFs {..} where consF = f
count :: Num a => ConsSemiring b a
count = sumproductBy (ConsListMapFs {consF = const 1})
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))
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