combinatorical functions for lambdaheads - 2012-01-09

MyCombinatorics.hs

module MyCombinatorics where

import Data.List ( (\\),
                   sort)
import Control.Applicative ( liftA2,
                             Applicative,
                             pure)

(^*) :: (a -> b) -> (b -> c) -> a -> c
f ^* g = g . f

-- | ungeordnete Variation ohne zurücklegen $\left(\begin{array}n\\k\end{array}$
-- take k elements from a set of n elements i.e. (1,2,3) -> ((1,2),(1,3),(2,3))
binom :: Integral a => a -> a -> a
binom n k = product [n,n-1..n-k+1] `div` product [1..k]

unorderedVariation :: [a] -> Int -> [a]
unorderedVariation x n | n < 0 = error "no nonpositive number chosen"
                       | otherwise = map fst $ applyN uV n [([], reverse x)]

uV :: [([a],[a])] -> [([a],[a])]
uV = concatMap uV'

uV' :: ([a],[a]) -> [([a],[a])]
uV' = _uV' []
    where _uV' :: [([a],[a])] -> ([a],[a]) -> [([a],[a])]
          _uV' acc (_,[]) = acc
          _uV' acc (yy,x:xx)= _uV' ((x:yy,xx):acc) (yy,xx)

nFaculty :: (Integral a) => a -> a
nFaculty n = product [1..n]

permute ::(Eq a) => [a] -> [[a]]
permute xx = treeToList $ maketree ([],reverse xx)

data Tree a = Leaf [a]
            | Node [Tree a]

treeToList :: Tree a -> [[a]]
treeToList (Leaf x) = [x]
treeToList (Node xx) = concatMap treeToList xx

maketree :: (Eq a) => ([a],[a]) -> Tree a
maketree (xx,[]) = Leaf xx
maketree (xx,yy) = Node [maketree (x : xx, yy \\ [x])|x <- yy]

maketree2 :: (Eq a) => ([a],[a]) -> Int -> Tree a
maketree2 (xx,[]) _ = Leaf xx
maketree2 (xx,yy) 0 = Leaf xx
maketree2 (xx,yy) n = Node [maketree2 (x : xx, yy \\ [x]) (n-1)|x <- yy]

set :: (Ord a, Eq a) => [a] -> [a]
set xx = sort (_set [] xx)

_set :: (Eq a) => [a] -> [a] -> [a]
_set acc [] = acc
_set acc (x:xx) |x ∈ acc = _set acc xx
                |otherwise = _set (x:acc) xx

ordVarWithPutBack :: [a] -> Int -> [[a]]
ordVarWithPutBack xx n = sequenceA (take n $ repeat xx)

ordVarNoPutBack :: (Eq a) => [a] -> Int -> [[a]]
ordVarNoPutBack xx n = treeToList (maketree2 ([],xx) n)

(∈) :: (Eq a) => a -> [a] -> Bool
x ∈ xx = x `elem` xx

applyN :: (a -> a) -> Int -> a -> a
applyN f n x = foldr ($) x (replicate n f)

sequenceA :: (Applicative f) => [f a] -> f [a]
sequenceA = foldr (liftA2 (:)) (pure [])

tMyCombinatorics.hs

import Test.HUnit
import MyCombinatorics

main = testAll

testAll = runTestTT $ TestList tests


--------------------------------------------------------------------------------
tests =
  ["unordered Variation" ~: "1" ~: True ~?= True,
   "unordered Variation" ~: "1 1" ~: unorderedVariation [1] 1 ~?= [[1]],
   "unordered Variation" ~: "2 1" ~: unorderedVariation [1,2] 2 ~?= [[1,2]],
   "unordered Variation" ~: "2 2" ~: unorderedVariation [1,2] 1 ~?= [[1],[2]],
   "unordered Variation" ~: "3 1" ~: unorderedVariation [1,2,3] 1 ~?= [[1],[2],[3]],
   "unordered Variation" ~: "3 2" ~: unorderedVariation [1,2,3] 2 ~?= [[1,2],[1,3],[2,3]],
   "unordered Variation" ~: "3 3" ~: unorderedVariation [1,2,3] 3 ~?= [[1,2,3]],
   "Permutation"         ~: "[1]" ~: permute [1] ~?= [[1]],
   "Permutation"         ~: "[1,2]" ~: permute [1,2] ~?= [[1,2],[2,1]],
   "Permutation"         ~: "[1,2,3]" ~: permute [1,2,3] ~?= [[1,2,3],[2,1,3],[1,3,2],[3,1,2],[2,3,1],[3,2,1]],
   "Set"         ~: "take 33 $ cycle [1,2,3]" ~: set ( take 33 (cycle [1,2,3])) ~?= [1,2,3]
  ]

Text vom Test zu "unorderedVariation [1,2] 2" mit dem von "unorderedVariation [1,2] 1" vertauscht.