ConsList.hs

{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell  #-}

{-
  Definitions for applying the generic GTA framework to cons lists.
  (we can make a concise, specialized GTA framework for cons-lists, but...)
 -}

module GTA.Data.ConsList (ConsList(Cons, Nil), ConsListAlgebra(ConsListAlgebra), cons, nil, consize, deconsize, segs, inits, tails, subs, assigns, 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 (..))


-- cons list = the usual list in FP
data ConsList a = Cons a (ConsList a)
                | Nil
--             deriving (Show, Eq, Ord, Read)
 
-- to use the GTA framework
genAllDecl ''ConsList

-- stupid consize function
consize :: forall a. [a] -> ConsList a
consize = foldr Cons Nil

-- stupid deconsize function
deconsize :: forall a. ConsList a -> [a]
deconsize = hom (ConsListAlgebra{cons=(:),nil=[]})
            --this hom is of GenericSemiringStructure, namely, foldr

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)

-- short-cut to ConsListAlgebra

foldr' :: forall a s.(a -> s -> s) -> s -> ConsListAlgebra a s
foldr' f e = ConsListAlgebra {cons = f, nil = e}


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

{- this generates lists from a tree, while CYK geenerates trees from a list -}
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

-- useful function to map
mapC :: forall b a. (b -> a) -> ConsListMapFs b a
mapC f = ConsListMapFs {..} where consF = f

-- ConsList-semiring for counting
count :: Num a => ConsSemiring b a
count = sumproductBy (ConsListMapFs {consF = const 1})


{- simplified aggregators -}

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



--- useful functions to design generators: constructors of bags of lists
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