Generate.hs

{-# LANGUAGE NoImplicitPrelude 
           , GADTs
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
  #-}

-- | Generation of species: given a species and an underlying set of
--   labels, generate a list of all structures built from the
--   underlying set.
module Math.Combinatorics.Species.Generate
    ( generateF
    , Structure(..)
    , generate

    ) where

import Math.Combinatorics.Species.Class
import Math.Combinatorics.Species.Types
import Math.Combinatorics.Species.Algebra

import Control.Arrow (first, second)
import Data.List (genericLength)

import NumericPrelude
import PreludeBase hiding (cycle)

-- | Given an AST describing a species, with a phantom type parameter
--   describing the species at the type level, and an underlying set,
--   generate a list of all possible structures built over the
--   underlying set.  Of course, the type of the output list is a
--   function of the species structure.  (Of course, it would be
--   really nice to have a real dependently-typed language for this!)
--
--   Unfortunately, 'SpeciesAlgT' cannot be made an instance of
--   'Species', so if we want to be able to generate structures given
--   an expression of the 'Species' DSL as input, we must take
--   'SpeciesAlg' as input, which existentially wraps the phantom
--   structure type---but this means that the output list type must be
--   existentially quantified as well; see 'generate' below.
generateF :: SpeciesAlgT s -> [a] -> [StructureF s a]
generateF O _   = []
generateF I []  = [Const 1]
generateF I _   = []
generateF X [x] = [Identity x]
generateF X _   = []
generateF (f :+: g) xs = map (Sum . Left ) (generateF f xs) 
                      ++ map (Sum . Right) (generateF g xs)
generateF (f :*: g) xs = [ Prod (x, y) | (s1,s2) <- pSet xs
                                       ,       x <- generateF f s1
                                       ,       y <- generateF g s2
                         ]
generateF (f :.: g) xs = [ Comp y | p  <- sPartitions xs
                                  , xs <- mapM (generateF g) p
                                  , y  <- generateF f xs
                         ]
generateF (Der f) xs = map Comp $ generateF f (Star : map Original xs)
generateF E xs = [xs]
generateF C [] = []
generateF C (x:xs) = map (Cycle . (x:)) (sPermutations xs)
generateF (OfSize f p) xs | p (genericLength xs) = generateF f xs
                          | otherwise     = []
generateF (OfSizeExactly f n) xs | genericLength xs == n = generateF f xs
                                 | otherwise = []

-- | @pSet xs@ generates the power set of @xs@, yielding a list of
--   subsets of @xs@ paired with their complements.
pSet :: [a] -> [([a],[a])]
pSet [] = [([],[])]
pSet (x:xs) = mapx first ++ mapx second 
  where mapx which = map (which (x:)) $ pSet xs

-- | Generate all partitions of a set.
sPartitions :: [a] -> [[[a]]]
sPartitions [] = [[]]
sPartitions (s:s') = do (sub,compl) <- pSet s'
                        let firstSubset = s:sub
                        map (firstSubset:) $ sPartitions compl

-- | Generate all permutations of a list.
sPermutations :: [a] -> [[a]]
sPermutations [] = [[]]
sPermutations xs = [ y:p | (y,ys) <- select xs
                         , p      <- sPermutations ys
                  ]

-- | Select each element of a list in turn, yielding a list of
--   elements, each paired with a list of the remaining elements.
select :: [a] -> [(a,[a])]
select [] = []
select (x:xs) = (x,xs) : map (second (x:)) (select xs)

-- | An existential wrapper for structures.  For now we just ensure
--   that they are Showable; in a future version of the library I hope
--   to be able to add a Typeable constraint as well, so that we can
--   actually usefully recover the generated values if we know what
--   type we are expecting.
data Structure a where
  Structure :: (ShowF f) => f a -> Structure a

instance (Show a) => Show (Structure a) where
  show (Structure t) = showF t

-- | We can generate structures from a 'SpeciesAlg' (which is an
--   instance of 'Species') only if we existentially quantify over the
--   output type.  However, we have guaranteed that the structures
--   will be Showable.  For example:
--
-- > > generate octopi ([1,2,3] :: [Int])
-- > [{{*,1,2,3}},{{*,1,3,2}},{{*,2,1,3}},{{*,2,3,1}},{{*,3,1,2}},{{*,3,2,1}},
-- >  {{*,1,2},{*,3}},{{*,2,1},{*,3}},{{*,1,3},{*,2}},{{*,3,1},{*,2}},{{*,1},
-- >  {*,2,3}},{{*,1},{*,3,2}},{{*,1},{*,2},{*,3}},{{*,1},{*,3},{*,2}}]
--
-- Of course, this is not the output we might hope for; octopi are
-- cycles of lists, but above we are seeing the fact that lists are
-- implemented as the derivative of cycles, so each list is
-- represented by a cycle containing *.  In a future version of this
-- library I plan to implement a system for automatically converting
-- between isomorphic structures during species generation.
generate :: SpeciesAlg -> [a] -> [Structure a]
generate (SA s) xs = map Structure (generateF s xs)


-- Experimental stuff below, automatically converting between
-- isomorphic structures.
--
-- class Iso f g where
--   iso :: f a -> g a

-- instance Iso (Comp Cycle Star) [] where
--   iso (Comp (Cycle (_:xs))) = map (\(Original x) -> x) xs

-- instance (Iso f g, Functor h) => Iso (Comp h f) (Comp h g) where
--   iso (Comp h) = Comp (fmap iso h)

-- instance (Iso f1 f2, Iso g1 g2) => Iso (Sum f1 g1) (Sum f2 g2) where
--   iso (Sum (Left x)) = Sum (Left (iso x))
--   iso (Sum (Right x)) = Sum (Right (iso x))

-- instance (Iso f1 f2, Iso g1 g2) => Iso (Prod f1 g1) (Prod f2 g2) where
--   iso (Prod (x,y)) = Prod (iso x, iso y)

-- generateFI :: (Iso (StructureF s) f) => SpeciesAlgT s -> [a] -> [f a]
-- generateFI s xs = map iso $ generateF s xs