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',ConsListMapFs(consF)) where
import GTA.Core
import GTA.Util.GenericSemiringStructureTemplate
import GTA.Data.BinTree (BinTree (..))
data ConsList a = Cons a (ConsList a)
| Nil
data ConsListAlgebra b a = ConsListAlgebra {
cons :: b -> a -> a,
nil :: a
}
data ConsListMapFs b b' = ConsListMapFs {
consF :: b -> b'
}
instance GenericSemiringStructure (ConsListAlgebra b) (ConsList b) (ConsListMapFs b) where
freeAlgebra = ConsListAlgebra {..} where
cons = Cons
nil = Nil
pairAlgebra cla1 cla2 = ConsListAlgebra {..} where
cons a (r1, r2) = (cons1 a r1, cons2 a r2)
nil = (nil1, nil2)
(cons1, nil1) = let ConsListAlgebra {..} = cla1 in (cons, nil)
(cons2, nil2) = let ConsListAlgebra {..} = cla2 in (cons, nil)
makeAlgebra (CommutativeMonoid {..}) cla frec fsingle = ConsListAlgebra {..} where
cons a r = foldr oplus identity [fsingle (cons' a r') | r' <- frec r]
nil = fsingle nil'
(cons', nil') = let ConsListAlgebra {..} = cla in (cons, nil)
foldingAlgebra op iop (ConsListMapFs {..}) = ConsListAlgebra {..} where
cons a r = consF a `op` r
nil = iop
hom (ConsListAlgebra {..}) = h where
h (Cons a r) = cons a (h r)
h Nil = nil
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