DouKaku?

module Main
    where

n = 6

firsts = [(1, x) | x <- [2..n]]
rests = [(x, y) | x <- [2..n], y <- [(x+1)..n]]

cMatchesPerDay = n `div` 2

filterCollision :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
filterCollision lst (x, y) = filter (matchxory.fst) $ filter (matchxory.snd) lst
    where 
        matchxory :: Int -> Bool
        matchxory a = (a /= x) && (a /= y)

dayMatches :: [(Int, Int)] -> Int -> [(Int, Int)] -> [(Int, Int)]
dayMatches (x:xs) 1 t = t ++ [x]
dayMatches [] _ t = t

dayMatches restsFiltered@(x:xs) c daymatch
    | (length next) /= cMatchesPerDay = dayMatches xs c daymatch
    | otherwise = next
    where
        next = dayMatches (filterCollision xs x) (c - 1) (daymatch ++ [x])

generateTournament :: (Int, Int) -> [(Int, Int)] -> ([(Int, Int)], [(Int, Int)])
generateTournament firstMatch moves = (tournament, moves')
    where
        tournament = dayMatches (filterCollision moves firstMatch) (cMatchesPerDay - 1) [firstMatch]
        moves' = filter (\x -> not $ elem x tournament) moves

mapToFirsts [] _ = []
mapToFirsts (x:xs) moves = (tournament : mapToFirsts xs moves')
    where
        (tournament, moves') = generateTournament x moves

showMatches lst = mapM_ (putStrLn.show) lst

main = showMatches $ mapToFirsts firsts rests

import Control.Monad (guard)
import Data.List ((\\))

list _ [] = [[]]
list (n,_) xs = concat [f x y | x <- xs, y <- xs, n < x, x < y]
  where f x y = map ((x,y):) (list (x,y) (xs \\ [x,y]))

pairs (x:xs) = map (\y -> pairs' x y (xs \\ [y])) xs
  where pairs' x y xs = map ((x,y):) (list (0,0) xs)

schedules _ [] = [[]]
schedules prev (xs:xss) = concat $ do
  x <- xs
  guard $ and $ map (\e -> e `notElem` prev) x
  return $ map (x:) (schedules (prev ++ x) xss)

main = mapM_ print (schedules [] (pairs [1..6]))

import Data.List (delete,intersect)
import Data.Map (fromList,(!),update)
import Control.Monad (mapM)
import Control.Monad.State (get,put,lift,evalStateT)

roundRobin n = evalStateT (mapM f [2..n]) $ fromList
  $ [(j,matches)| i <- [1,3..n], j <- [i,i+1],
      let matches = [2..i-1] ++ [i+2..n]]  where

  f 2 = return [(i,i+1)| i <- [1,3..n]]  -- １日目    [(1,2),(3,4)...(n-1,n)]
  f i = g [(1,i)] (delete i [2..n])      -- (i-1)日目 [(1,i), ??? ]

  g ms [] = return ms
  g ms (x1:xs) = do
    r <- get
    x2 <- lift $ xs `intersect` (r!x1)
    put $ update (Just.(delete x1)) x2 $ update (Just.(delete x2)) x1 r
    g (ms++[(x1,x2)]) (delete x2 xs)

printRoundRobin n = mapM_ print $ roundRobin n
{-
> printRoundRobin 6
[[(1,2),(3,4),(5,6)],[(1,3),(2,5),(4,6)],[(1,4),(2,6),(3,5)],[(1,5),(2,4),(3,6)],[(1,6),(2,3),(4,5)]]
[[(1,2),(3,4),(5,6)],[(1,3),(2,6),(4,5)],[(1,4),(2,5),(3,6)],[(1,5),(2,3),(4,6)],[(1,6),(2,4),(3,5)]]
-}