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

-- | This module provides the GTA framework on cons lists, such as
-- definitions of the data structure and its algebra, generators,
-- aggregators, etc.
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),mapMap,perms) where


import GTA.Core
import GTA.Util.GenericSemiringStructureTemplate
import GTA.Data.BinTree (BinTree (..))
import qualified Data.IntSet as IntSet


-- 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
-- The following definitions can be generated automatically by @genAllDecl ''ConsList@
-- They are written by hand here for writing comments.

-- algebra of ConsList
data ConsListAlgebra b a = ConsListAlgebra {
      cons  :: b -> a -> a,
      nil    :: a
    }

-- a set of functions for 'map'
data ConsListMapFs b b' = ConsListMapFs {
      consF :: b -> b'
    }

-- type parameters are algebra, free algebra, and functions for 'map'
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

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

perms :: [a] -> ConsSemiring a s -> s
perms x = assigns (zip [1..n] x) [1..n] `transformBy` mapMap fst `filterBy` spans n `transformBy` mapMap snd
  where n = length x

spans n = ok <.> foldr' f e where
    e = IntSet.empty
    f (v,_) x = IntSet.insert v x
    ok x = IntSet.size x == n

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


mapMap :: (b -> b') -> GenericSemiring (ConsListAlgebra b') a -> GenericSemiring (ConsListAlgebra b) a
mapMap f (GenericSemiring {..}) = 
    GenericSemiring {algebra=algebra',monoid=monoid} where
    ConsListAlgebra{..} = algebra
    algebra' = ConsListAlgebra{cons=cons.f,nil=nil}