FunWithCombinatorialSpecies.hs

{-# LANGUAGE DeriveGeneric
           , DeriveDataTypeable
           , TypeFamilies
           , TypeOperators
  #-}

import Prelude hiding ((+), (*), (^))
import NumericPrelude
import Data.List (inits)
import Math.Combinatorics.Species
import Math.Combinatorics.Species.Types
import Math.Combinatorics.Species.AST
import Math.Combinatorics.Species.AST.Instances
import Math.Combinatorics.Species.Structures
import Data.Typeable

data BinTreeC = BinTreeC deriving (Typeable, Show)
data BinTree a = Leaf a | Node a (BinTree a) (BinTree a)

type instance Interp BinTreeC self = Id :+: (Id :*: (self :*: self))

instance ASTFunctor BinTreeC where
  apply _ self = annI TX :+:: annI (annI TX :*:: annI (annI self :*:: annI self))

instance Enumerable BinTree where
  type StructTy BinTree = Mu BinTreeC
  iso (Mu (Inl (Id a))) = Leaf a
  iso (Mu (Inr ((Id a) :*: (l :*: r)))) = Node a (iso l) (iso r)

data RoseTreeC = RoseTreeC deriving (Typeable, Show)
data RoseTree a = RoseTree a [RoseTree a]

type instance Interp RoseTreeC self = Id :*: ([] :.: self)

instance ASTFunctor RoseTreeC where
  apply _ self = annI TX :*:: annI (annI TL :.:: annI self)

instance Enumerable RoseTree where
  type StructTy RoseTree = Mu RoseTreeC
  iso (Mu ((Id a) :*: (Comp cs))) = RoseTree a (map iso cs)

main :: IO ()
main = do
  -- Eine Surjektion auf die Menge {1..k} ist gegeben durch ihre k Urbilder
  -- (die nicht leer sind)
  putStrLn $ "Surjektionen einer n-elementigen Menge auf eine " ++
    show k ++ "-elementige Menge:"
  print $ start $ labelled $ (nonEmpty set) ^ k
  -- Alternative:
  --print $ start $ labelled $ (ofSizeExactly linOrd k) `o` (nonEmpty set)
  putStrLn $ "Surjektionen von einer n-elementigen Menge:"
  print $ start $ labelled $ linOrd `o` nonEmpty set

  -- Eine Injektion der Menge {1..k} ist gegeben durch eine Bijektion aufs Bild
  -- und den Rest:
  putStrLn $ "\nInjektionen der Menge {1, ..., " ++ show k ++ "} in eine" ++
    "n-elementige Menge:"
  print $ start $ labelled $ ofSizeExactly linOrd k * set
  putStrLn $ "Injektionen in eine n-elementige Menge:"
  print $ start $ labelled $ linOrd * set

  -- Ein idempotenter Endofunktor auf {1..n} ist gegeben durch Partitionen von
  -- {1..n} und ein ausgewähltes Element in jeder Teilmenge
  putStrLn $ "\nAnzahl idempotenter Endofunktoren auf {1, ..., n}"
  print $ start $ labelled $ set `o` (singleton * set)
  -- siehe: http://topologicalmusings.wordpress.com/2009/03/28/number-of-idempotent-endofunctions/

  -- Eine Involution auf {1..n} ist gegeben durch eine Überdeckung von {1..n}
  -- durch Mengen der Mächtigkeit 1 oder 2 (für alle Fixpunkte bzw. alle Paare
  -- von Zahlen, die aufeinander abgebildet werden)
  putStrLn $ "\nAnzahl der Involutionen auf {1, ..., n}:"
  print $ start $ labelled $ set `o` ofSize set (`elem` [1,2])
  -- Alternative:
  --print $ start $ labelled $ set `o` (ofSizeExactly set 1 + ofSizeExactly set 2)

  putStrLn $ "\nAnzahl der Oktopoden mit n bunten Steinen"
  print $ start $ labelled $ Math.Combinatorics.Species.cycle `o` nonEmpty linOrd
  -- Diese Spezies ist sogar vordefiniert:
  --print $ start $ labelled octopi

  putStrLn $ "\nAnzahl der Binärbäume mit 5 verschiedenen Werten: " ++
    show (length (enumerate (rec BinTreeC) [1..5] :: [BinTree Int]))
  --print $ start $ map (length . (enumerate (rec BinTreeC) :: [Int] -> [BinTree Int])) $ inits [1..]

  putStrLn $ "\nAnzahl der Informatikerbäume mit 5 verschiedenen Werten: " ++
    show (length (enumerate (rec RoseTreeC) [1..5] :: [RoseTree Int]))
  --print $ start $ map (length . (enumerate (rec RoseTreeC) :: [Int] -> [RoseTree Int])) $ inits [1..]
  where
    k = 4
    start = take 16