logic-puzzle-festival.hs

#!/usr/bin/env runhaskell

-- На международном фестивале собрались n участников. Если взять любую подгруппу
-- из m участников, то в этой подгруппе найдутся двое, которые разговаривают на
-- одном языке.  
-- 
-- Проверить следующее утверждение: в любой подгруппе размера k участники могут
-- объясниться друг с другом.

import Data.List

n = 6
m = 3
k = 3

-- перенумеруем участников
type Person = Int
persons = [1..n]

-- Если X и Y знают общий язык и X < Y то учитываем только пару (X, Y) но не
-- (Y,X)
type LangSet = [ (Person, Person) ]

all_pairs list = [ (first, second) | 
  first <- list, second <- list, first < second ]

subsequences_of_given_length :: [a] -> Int -> [[a]]
subsequences_of_given_length list len = filter (\l -> length(l) == len) (subsequences list)

all_langsets :: [ LangSet ]
all_langsets = subsequences $ all_pairs persons

all_satisfying_langsets :: [ LangSet ]
all_satisfying_langsets = filter satisfies_problem_statement all_langsets where
  satisfies_problem_statement langset = all has_same_lang_pair all_subgroups where
    all_subgroups = subsequences_of_given_length persons m
    has_same_lang_pair group = length(intersect (all_pairs group) langset) > 0
  
any_group_can_talk langset = all group_can_talk (subsequences_of_given_length persons k) where
  group_can_talk group = graph_connected nodes edges where
    nodes = group
    edges = langset

graph_connected :: [Person] -> LangSet -> Bool
graph_connected nodes edges = let
  sorted_edges = sort edges
  connected_nodes = foldl connect_edges [] sorted_edges
  connect_edges []   (l,r) = [l,r]
  connect_edges conn (l,r) = if elem l conn then r:conn else if elem r conn then l:conn else conn
  in all (\n -> n `elem` connected_nodes) nodes


--result = all any_group_can_talk all_satisfying_langsets
result = head $ filter (\langset -> not(any_group_can_talk(langset))) all_satisfying_langsets
main = putStrLn $ show $ result