Показаны сообщения с ярлыком 1HaskellADay. Показать все сообщения
Показаны сообщения с ярлыком 1HaskellADay. Показать все сообщения

пятница, 5 июня 2015 г.

Алгоритм Крускала для невзвешенного графа на haskell

Очередная задачка от 1HaskellADay. В условии задан список ребер графа. Многие пути вдоль ребер предположительно зациклены, то есть если есть два пути от a к b и от b к c, то, возможно, в списке присутствует также путь от a к c; сюда же относятся вырожденные циклы, когда имеется несколько путей от a к b, либо имеются обратные пути от b к a. Целью задачи является удаление лишних (redundant) ребер графа, которые приводят к появлению циклов. Очевидно, разрешение цикла всегда связано с удалением произвольного ребра: скажем, в случае цикла (a, b, c) его разрешением может стать удаление любого из трех ребер (a, b), (b, c) и (a, c). Алгоритм Крускала находит минимальное остовное дерево (minimum spanning tree) для взвешенного неориентированного графа. Давайте предположим, что нам неважны направления ребер. В этом случае, принимая во внимание, что невзвешенный граф — это частный случай взвешенного, а дерево — это связный ациклический граф, алгоритм Крускала идеально подходит для решения нашей задачи. Напомню его суть. В случае взвешенного графа все ребра предварительно сортируются по весу (этот шаг гарантирует построение минимального дерева). Затем проходом по всем ребрам строится лес, постепенно объединяющийся в единое дерево, либо в список крупных деревьев, если исходный граф несвязан. В процессе прохода может оказаться, что очередное ребро сформирует цикл — в этом случае оно просто отбрасывается. Как определить, что ребро может сформировать цикл? Перед началом прохода все вершины (vertices) графа заносятся в специальную структуру, которая называется disjoint set. Эта структура представляет собой один или более наборов чисел, каждый из которых имеет своего представителя (representative) — это число, которое является меткой набора. На старте алгоритма все вершины разъединены и, составляя отдельные наборы, выставляют в качестве представителя самих себя. В процессе прохода по всем ребрам отдельные наборы будут объединяться, выбирая в качестве представителя одну из вершин в объединенном наборе. Соответственно, если в процессе прохода обеим вершинам очередного ребра соответствует один и тот же представитель, то это ребро отбрасывается, иначе обе вершины объединяются. Структура disjoint set гарантирует, что если одна из вершин уже была объединена в некоторый набор, то в случае ее объединения с другой вершиной, эта другая вершина вместе с набором, к которому она относится, объединится с первым набором, возможно сформировав нового представителя. Так постепенно формируется единый набор вершин (или несколько крупных). Алгоритм для работы с disjoint set часто называют union-find. Он гарантирует константное время объединения и поиска представителя. Я не собираюсь его здесь реализовывать, а лучше возьму одну из многочисленных существующих реализаций для языка haskell: Data.UnionFind.IO. Представленная в этом модуле реализация disjoint set не поддерживает поиск представителя для произвольного числа: только числа, уже добавленные в набор, корректно возвращают своего представителя. Поскольку мы добавляем все вершины в набор на старте, нам достаточно создать Map, ключами которого будут числа-вершины, а значениями — представления этих чисел в наборе disjoint set. Таким образом, мы сможем находить представителей вершин в процессе прохода по ребрам графа за логарифмическое время. Учитывая линейность прохода по ребрам, общий класс алгоритма должен соответствовать O(nlogm)O(n\log{}m), где n — число ребер исходного графа, а m — число вершин. Вот исходный код функции deredundancify, которая из исходного списка ребер строит список всех вершин графа и остовное дерево.
deredundancify :: [Edge] -> IO ([Vertex], [Edge])
deredundancify es = do
    let vs = map head . group . sort $ foldr (\(a, b) c -> a : b : c) [] es
    ps <- mapM fresh vs
    m  <- liftM M.fromList $ mapM (\a -> do b <- descriptor a; return (b, a)) ps
    let testNotCycle (a, b) = do
            let pa = fromJust $ M.lookup a m
                pb = fromJust $ M.lookup b m
            da <- descriptor pa
            db <- descriptor pb
            if da == db
                then return False
                else do
                    pa `union` pb
                    return True
    rs <- filterM testNotCycle es
    return (vs, rs)
Для того, чтобы все скомпилировалось, перед определением функции нужно добавить импорт некоторых модулей и определить синонимы типов Vertex и Edge.
import            Control.Monad               (liftM, filterM)
import            Data.List                   (sort, group)
import qualified  Data.Map                    as M
import            Data.UnionFind.IO
import            Data.Maybe                  (fromJust)

type Vertex = Int
type Edge   = (Int, Int)
Внутри функции deredundancify сначала строится список вершин vs, затем все вершины заносятся в структуру ps с помощью функции fresh из модуля Data.UnionFind.IO. Затем строится Map m, ключами которого являются представители (descriptor) исходного набора ps (которые вначале должны просто соответствовать вершинам vs), а значениями — исходные наборы из ps. Основная работа функции deredundancify заключается в формировании списка ребер rs, который будет соответствовать искомому остовному дереву. Список rs строится за счет применения фильтра testNotCycle к исходному списку ребер es. Фильтр testNotCycle ищет наборы pa и pb внутри m, получает их дескрипторы da и db и сравнивает их. Если дескрипторы равны, то данное ребро отбрасывается (функция возвращает False), иначе — pa и pb объединяются (union) и данное ребро заносится в список для остовного дерева (функция возвращает True). Собственно, это и есть решение задачи. Но давайте подумаем, как мы его проверим. Из большого списка ребер мы получим список чуть поменьше. И что нам с ним делать? Нужна какая-то визуализация. Очевидное решение — использовать GraphViz. В haskell есть байндинг для GraphViz. Давайте напишем функцию, которая будет выводить текст в формате dot, который GraphViz сможет использовать для изображения графов. Прежде всего, подключим модули GraphViz.
import            Data.Graph.Inductive        hiding (Edge)
import            Data.GraphViz
import            Data.GraphViz.Attributes
import            Data.GraphViz.Printing      (renderDot)
import            Data.Text.Lazy              (Text, unpack, pack)
import            System.Environment          (getArgs)
Последний импорт понадобится в функции main для парсинга аргументов командной строки. Вот функция mkDot.
mkDot :: [Vertex] -> [Edge] -> [GlobalAttributes] -> DotGraph Node
mkDot vs es attrs =
    let lvs = map (\a -> (a, pack $ show a)) vs
        les = map (\(a, b) -> (a, b, ())) es
        gr  = mkGraph lvs les :: Gr Text ()
    in graphToDot nonClusteredParams {globalAttributes = attrs} gr
Она принимает список вершин, список ребер и атрибуты GraphViz и возвращает промежуточное представление для данных dot. Давайте напишем функцию main, которая сможет выводить данные dot на экран.
main = do
    args     <- getArgs
    (vs, rs) <- deredundancify theGraph
    let attrs = [EdgeAttrs
                    [edgeEnds $ if "-l" `elem` args then NoDir else Forward]]
        dot   = mkDot vs (if "-o" `elem` args then theGraph else rs) attrs
    putStrLn $ unpack $ renderDot $ toDot dot
Теперь, после компиляции исходного кода, предварительно включив в него список ребер исходного графа theGraph, можно вывести исходный граф и искомое остовное дерево на картинку. Получение картинки исходного графа.
./deredundancify -o | dot -Tpng > original.png
Получение картинки остовного дерева исходного графа.
./deredundancify | dot -Tpng > deredundancified.png
Картинки для исходного дерева, представленного в оригинальном примере, получаются очень большими, поэтому я их положил на Google Drive: исходный граф, остовное дерево. Посмотрите и сравните: по картинкам становится понятно, что такое большое остовное дерево. Кстати, на выложенных картинках все ребра направлены, но по условиям нашей задачи граф неориентирован, поэтому по-хорошему стрелки на ребрах должны отсутствовать. Не проблема, если хотите картинки без стрелок — используйте опцию -l при вызове deredundancify. Исходный код решения задачи можно загрузить отсюда или отсюда. Update. Как обычно, ряд улучшений в исходном коде уже после публикации статьи. Все они касаются функции deredundancify. Во-первых, создание структуры ps для uninon-find и ассоциативного массива m можно объединить. Это потому, что вначале все наборы внутри ps состоят из отдельных вершин и их представителями являются собственно сами эти вершины. Во-вторых, я предпочитаю избегать конструкцию if-then-else в haskell. В данном случае в функции testNotCycle вместо нее можно определить логическую константу, применив оператор liftM2 (==) или liftM2 (/=) к значениям представителей вершин ребра, а необходимость объединения вершин определять с помощью функции when из модуля Control.Monad. Функция liftM2 определена в этом же модуле. Чтобы не плодить список импортированных из него функций, лучше переписать его импорт как
import            Control.Monad
В-третьих, поиск внутри m можно переписать в стрелочном стиле. Для этого нужно включить еще один импорт.
import            Control.Arrow
Я писал про стрелки в haskell в предыдущей статье. Теперь функция deredundancify выглядит так.
deredundancify :: [Edge] -> IO ([Vertex], [Edge])
deredundancify es = do
    let vs = map head . group . sort $ foldr (\(a, b) c -> a : b : c) [] es
    m  <- liftM M.fromList $ mapM (\v -> do p <- fresh v; return (v, p)) vs
    let testNotCycle e = do
            let ve = both (fromJust . flip M.lookup m) e
            notCycle <- uncurry (liftM2 (/=)) $ both descriptor ve
            when notCycle $ uncurry union ve
            return notCycle
            where both = join (***)
    rs <- filterM testNotCycle es
    return (vs, rs)
Я заменил запись аргумента функции testNotCycle (a, b) на e, поскольку стрелочная нотация прекрасно работает с кортежами и в ней не требуется знать его (кортежа) отдельные элементы. Функция both заворачивает стрелочный комбинатор (***) в функцию join из модуля Control.Monad, таким образом применяя свой аргумент-функцию к обоим элементам кортежа. И еще одна техника, которая позволит переписать монадные вычисления внутри отображения mapM при вычислении m в бесточечном стиле. Это стрелки Клейсли. Они импортируются из модуля Control.Arrow по умолчанию. Основная идея заключается в оборачивании всех функции, возвращающих монадные значения в тип Kleisli, а само монадное вычисление — в конструктор runKleisli, который возвращает монадный тип из комбинации стрелок.
m  <- liftM M.fromList $ mapM (runKleisli $ arr id &&& Kleisli fresh) vs
Здесь из функции id создается обычная стрелка с помощью явного конструктора arr. Несмотря на то, что функции являются стрелками, и мы ни разу до этого не использовали явные конструкторы стрелок в отношении функций, в данном случае без них не обойтись — ghc откажется компилировать код. Другая стрелка — стрелка Клейсли — создается из функции fresh, возвращающей монадное значение IO (Point a). Обе стрелки комбинируются стрелочным комбинатором (&&&). На выходе runKleisli получаем монадное вычисление пары (входное значение (то есть вершина), элемент структуры union-find). Не думаю, что новое тело функции deredundancify понятней, чем предыдущее (скорее наоборот), зато оно явно лаконичней. Ну и напоследок упражнение: записать тело функции правой свертки (\(a, b) c -> a : b : c), которую мы использовали для получения списка всех вершин графа, в бесточечном стиле с помощью стрелок. Причем с сохранением семантики и эффективности: то есть числа a и b должны стыковаться со списком c в заданном порядке, а конструкторы списка (:) нельзя заменять на операции конкатенации (++). Я напишу ответ, но не стану его объяснять.
curry $ fst . fst &&& uncurry ((:) . snd) >>> uncurry (:)
А это бесточечное решение без использования стрелок, тоже без объяснения.
let (<:) = flip (:) in flip $ uncurry . flip . ((<:) .) . (<:)
Update 2. Я все-таки решил привести здесь уменьшенные варианты изображений оригинального графа и его осто́вного дерева в дополнение к приведенным выше ссылкам на большие изображения, которые оказались настолько большими, что вставлять их в статью было бы просто безумием. Новые изображения обязаны своей компактностью выбору движка для рендеринга sfdp вместо стандартного dot, отказу от прорисовки форм вершин графа (вернее, теперь это форма point) и их идентификаторов, а также выбору полупрозрачных цветов для ребер и вершин. Чтобы достичь этого, мне пришлось внести небольшие дополнения в исходный код программы. Итак, изображение исходного графа без идентификаторов вершин, полученное как
./deredundancify -o -t | sfdp -Tpng > original_tiny.png
А это осто́вное дерево, полученное как
./deredundancify -t | sfdp -Tpng > deredundancified_tiny.png
На первой картинке много синих линий-ребер, на второй их практически не видно, зато красные кружки́-вершины связаны в более длинные цепочки. Все это выглядит здо́рово и весьма достоверно.

пятница, 29 мая 2015 г.

Стрелки (arrows) и бесточечная (pointfree) нотация в haskell на конкретном примере

Стрелка — это модель обобщения вычислительного процесса, когда на вход вычисления может подаваться сразу несколько входных данных (например, в виде кортежа), а сам процесс вычисления строится с помощью комбинаторов типа first, second, (***), (&&&) и (>>>). Бесточечная нотация — это когда при записи функции в выражении (в том числе в ее определении), аргументы опускаются и, соответственно, не связываются (bind) в выражении. Поскольку стрелка абстрагирует входные данные, она выглядит хорошим кандидатом для применения в бесточечной нотации. Рассмотрим применение стрелки и бесточечной нотации на простом примере. Я взял его из очередного твита в 1HaskellADay. Задача простейшая — вывести на экран счет от целого числа from до целого числа to без использования явных циклов. Явные циклы в haskell, да и вообще в функциональном программировании, очень не приветствуются, поскольку относятся к миру императивного программирования. Поэтому данная задача выглядит простой и, в общем-то, таковой и является. Так как я собираюсь привести несколько решений, имеет смысл написать осто́вную функцию count, которая будет принимать основную функцию вычисления счета, передавать ей входные значения from и to, и выводить счет на экран.
count :: (Int -> Int -> [Int]) -> Int -> Int -> IO ()
count f from to = mapM_ print $ f from to
Здесь можно добавить проверку на то, что from меньше to, но я этого не сделал для простоты. Самую очевидную реализацию функции f я назвал cheating, поскольку в ней используется синтаксический сахар, предоставленный самим языком как раз для создания непрерывно возрастающего списка от некоторого числа m до некоторого числа n.
cheating from to = [from .. to]
Совершенно очевидное и незамысловатое решение. Его можно проверить в ghci или в функции main с помощью вызова
count cheating 1 10
Теперь простое решение без использования сахара haskell.
simple from to = takeWhile (<= to) . iterate succ $ from
Тоже несложно. Функция iterate succ строит бесконечный непрерывно увеличивающийся список, который начинается со значения from. Этот список трассируется функцией takeWhile до тех пор, пока выполняется предикат в скобках, то есть пока очередное значение в списке не превысит to. Обе функции cheating и simple просты и хороши. Но я бы хотел видеть их в бесточечной нотации, то есть без явного указания и связывания аргументов from и to. К сожалению, это невозможно, поскольку в первом случае синтаксис построения списка-диапазона требует указания обоих значений, а во втором случае значение to используется внутри предиката в самом центре тела функции. И здесь на помощь приходят стрелки! Для их использования необходимо импортировать модуль Control.Arrow.
import Control.Arrow
Я приведу тело функции arrowedPointfree, а ниже объясню, что в нем происходит.
arrowedPointfree = curry $ iterate succ *** (>=) >>> uncurry (flip takeWhile)
Видите, никаких from и to. Они неявно присутствуют в определении функции, но не связаны внутри ее тела. Оба аргумента склеиваются функцией curry в кортеж и передаются в вычислительный процесс, собранный из функций и стрелок, который начинается за символом $. Следуя традиции графического изображения стрелочных вычислений (см. здесь), я представлю (в меру своих художественных способностей) этот процесс вычисления на картинке.
Итак, кортеж (from, to) поступает на вход стрелочного комбинатора (***). Первый элемент кортежа (from) поступает на вход функции iterate succ, формируя бесконечный возрастающий список [from ..], второй (to) — на вход функции (>=), формируя новую функцию (>=) to. Заметьте, в функции simple мы использовали сечение (<= to). Наша новая функция эквивалентна сечению (to >=), что соответствует предикату из simple. На выходе комбинатора (***) новый кортеж ([from ..], (>=) to) поступает на оператор композиции (>>>), который передает вычисление в функцию uncurry. Функция uncurry декомпонует кортеж в последовательность двух аргументов (я изобразил это сужением вычислительного конвейера) и вызывает функцию flip takeWhile. Функция flip нужна для того, чтобы переставить аргументы [from ..] и (>=) to местами, сформировав takeWhile ((>=) to) [from ..]. Дело сделано! Не находите это решение красивым? Лично я нахожу. Это несмотря на то, что функции cheating и simple выглядят и проще, и понятнее. Но здесь нам удалось абстрагироваться от входных данных и сосредоточиться на потоке вычислений. Да, поначалу стрелки выглядят сложными, но только до тех пор, пока процесс вычисления не представлен графически. Есть еще один аспект. Часто в погоне за возможностью выразить код в бесточечном стиле (pointfree), программисты вынужденно усложняют понимание исходного кода, превращая его в pointless (бессмысленный). Поначалу я случайно назвал функцию arrowedPointfree arrowedPointless, и не сразу оценил всю глубину смысловой нагрузки этой оговорки. В этой статье приводится пример подобного усложнения (по мнению автора) и также обыгрываются синонимы pointfree и pointless. С другой стороны, невозможность записать выражение в бесточечном стиле может свидетельствовать об излишней монолитности функции. Попробуйте записать определение нашей осто́вной функции count в бесточечном стиле. Например,
count :: (Int -> Int -> [Int]) -> Int -> Int -> IO ()
count = mapM_ print
Этот вариант просто не скомпилируется: ghc пожалуется на то, что в функцию map передается слишком много аргументов. Максимальный уровень бесточечности, который можно выжать в определении функции count с такой сигнатурой, заключается в возможности опустить последний аргумент to, соединив mapM_ print и f from оператором (.).
count :: (Int -> Int -> [Int]) -> Int -> Int -> IO ()
count f from = mapM_ print . f from
Почему мы не можем выразить определение count в бесточечном стиле? Потому что мы намеренно усложнили ее определение, фактически объединив две разные функции в одну. Но в общем случае, зачем функции count знать о какой-то другой функции, принимающей какие-то аргументы и возвращающей список [Int]? Ей достаточно знать последний факт, то есть то, что она работает со списком целых чисел. Исходя из этого, определение count можно переписать в виде
count :: [Int] -> IO ()
count = mapM_ print
Вот и бесточечная нотация! Глядя на такое простое определение, мы можем заключить, что функция count нам вообще не нужна, это же просто mapM_ print, которую можно комбинировать напрямую в месте вызова. Например,
mapM_ print $ arrowedPointfree 1 10
Правда, в этом варианте пропало слово счет (count), но это уже вопрос правильного именования функций: при отсутствии осто́вной функции все функции счета следует переименовать.

среда, 1 апреля 2015 г.

Как я доказал математическую теорему с помощью haskell

В твиттере есть замечательный ресурс 1HaskellADay. Каждый день (или почти каждый) там предлагается решить какую-нибудь интересную задачу на языке haskell. Недавно решал такую задачку. Нужно найти непрерывную последовательность из 17 целых чисел, для каждого из которых существует другое число из этой же последовательности, такое, что эти два числа не являются взаимно простыми. Взаимно простыми (co-prime) называются такие два числа, у которых наибольший общий делитель (НОД или по-английски greatest common divisor (GCD)) больше 1. Так, числа 5 и 9 являются взаимно простыми, а все четные числа — нет, поскольку их НОД как минимум равен 2. Не взаимно простые числа называются по-английски co-composed (по крайней мере в этой задаче). Решение в haskell выглядит очень лаконично.
import Data.List

coComposedSet :: Integer -> [[Integer]]
coComposedSet s =
    [r | a <- [1 .. ], let r = [a .. a + s - 1],
     (== s) $ genericLength $ group [x | x <- r, y <- r, y /= x, gcd x y > 1]]
Функция coComposedSet состоит из двух строк и представляет собой генератор таких последовательностей длиной s на всем множестве целых чисел (поэтому типом множества выбран Integer, который не имеет ограничений). Чтобы получить первые 10 последовательностей длиной 17, нужно передать генератор функции take 10.
main :: IO ()
main = print $ take 10 $ coComposedSet 17
Считается эта штука достаточно быстро. Если скомпилировать программу с флагом -O2, то на моей машине Intel Core i5 время расчета составит чуть больше четырех секунд.
ghc --make -O2 coComposedSet.hs
[1 of 1] Compiling Main             ( coComposedSet.hs, coComposedSet.o )
Linking coComposedSet ...
time ./coComposedSet 
[[2184,2185,2186,2187,2188,2189,2190,2191,2192,2193,2194,2195,2196,2197,2198,2199,2200],
[27830,27831,27832,27833,27834,27835,27836,27837,27838,27839,27840,27841,27842,27843,27844,27845,27846],
[32214,32215,32216,32217,32218,32219,32220,32221,32222,32223,32224,32225,32226,32227,32228,32229,32230],
[57860,57861,57862,57863,57864,57865,57866,57867,57868,57869,57870,57871,57872,57873,57874,57875,57876],
[62244,62245,62246,62247,62248,62249,62250,62251,62252,62253,62254,62255,62256,62257,62258,62259,62260],
[87890,87891,87892,87893,87894,87895,87896,87897,87898,87899,87900,87901,87902,87903,87904,87905,87906],
[92274,92275,92276,92277,92278,92279,92280,92281,92282,92283,92284,92285,92286,92287,92288,92289,92290],
[117920,117921,117922,117923,117924,117925,117926,117927,117928,117929,117930,117931,117932,117933,117934,117935,117936],
[122304,122305,122306,122307,122308,122309,122310,122311,122312,122313,122314,122315,122316,122317,122318,122319,122320],
[147950,147951,147952,147953,147954,147955,147956,147957,147958,147959,147960,147961,147962,147963,147964,147965,147966]]

real    0m4.161s
user    0m4.147s
sys     0m0.013s
Я перенес все подсписки в отдельные строки для удобочитаемости, программа выводит всё в одну строку. А теперь переходим к теореме. Автор задачи попросил доказать, что не существует последовательностей длиной меньше 17, которые удовлетворяют условиям задачи. С короткими последовательностями длиной от 2 до 5 всё просто. Я приведу теоретические доказательства для этих случаев.
  • Длина 2. Легко показать, что все соседние числа являются взаимно простыми. В самом деле, пусть k является НОД двух соседних чисел n и n + 1. Тогда kl=nk \cdot l = n km=n+1k \cdot m = n + 1 , где l и m — произведения остальных делителей чисел n и n + 1. Отсюда следует, что k(ml)=1k \cdot (m - l) = 1 , а это значит, что k может быть равным только 1, то есть числа n и n + 1 — взаимно простые.
  • Длина 3. Число в середине последовательности является соседним для обоих крайних чисел, а значит взаимно простым с ними.
  • Длина 4. Возможны две зеркальные ситуации: последовательность начинается с четного числа или с нечетного. В обоих случаях нечетное число, находящееся между двумя четными, не может быть не взаимно простым ни с этими четными числами, так как они для него являются соседними, ни с крайним нечетным числом, поскольку для двух последовательных нечетных чисел должно выполняться равенство k(ml)=2k \cdot (m - l) = 2 , то есть k как НОД должен быть равен 2, однако это противоречит условию, что эти два числа нечетные.
  • Длина 5. Возможны два случая.
    • Четные числа по краям и в середине, нечетные - второе и четвертое. В этом случае, следуя ограничениям, выведенным в предыдущих случаях, второе число может быть не взаимно простым только с пятым, а четвертое — с первым. При этом их НОД должен удовлетворять условию k(ml)=3k \cdot (m - l) = 3 , следовательно он равен 3 для обоих нечетных чисел — второго и четвертого. Это противоречит нашему выводу о том, что два последовательных нечетных числа могут быть только взаимно простыми.
    • Нечетные числа по краям и в середине, четные - второе и четвертое. Среднее нечетное число является всегда взаимно простым с другими четырьмя — это также следует из уже доказанных свойств соседних чисел.
Случай с последовательностью из 16 чисел я теоретически доказывать не хочу, на мой взгляд это сложно, хотя, возможно, я упускаю какие-то простые факты, которые можно было бы использовать в доказательстве. Но я не буду этого делать еще по одной простой причине — доказательство можно легко провести с помощью простой программы на haskell! Идея такова. Внутри любой непрерывной последовательности из s чисел не существует числа, являющегося взаимно простым по отношению к остальным числам последовательности только в том случае, если ни одна из всевозможных комбинаций НОД-соседних чисел внутри заданной последовательности, включающая 2 и более элементов для всех НОД, соответствующих простым числам меньшим s, не задействует все элементы последовательности одновременно. НОД-соседними числами я называю идущие подряд четные числа, идущие подряд числа, кратные трем и так далее. Так, в случае последовательности длиной 16 нужно доказать, что ни одна из взаимных комбинаций НОД-соседних чисел для НОД равных 2, 3, 5, 7, 11 и 13 длиной от двух элементов не покрывает все 16 чисел последовательности одновременно. Следующая функция coComposedLayouts возвращает всевозможные комбинации НОД-соседних чисел внутри произвольной последовательности длиной s для заданного значения НОД m.
-- get all possible layouts of numbers with common factor m inside
-- an arbitrary contiguous range of s numbers; each layout must contain
-- at least 2 elements
coComposedLayouts :: Int -> Int -> [[Int]]
coComposedLayouts m s =
    filter ((> 1) . length . take 2) $
    map (takeWhile (<= s) . iterate (+ m)) [1 .. m]
Загрузим исходную программу (файл coComposedSet.hs) в ghci и проверим, как она работает.
:l coComposedSet.hs
[1 of 1] Compiling Main             ( coComposedSet.hs, interpreted )
Ok, modules loaded: Main.
coComposedLayouts 2 16
[[1,3,5,7,9,11,13,15],[2,4,6,8,10,12,14,16]]
coComposedLayouts 3 16
[[1,4,7,10,13,16],[2,5,8,11,14],[3,6,9,12,15]]
Числа внутри подсписков — индексы элементов внутри произвольной непрерывной последовательности чисел (от 1 до s), которые будут заняты НОД-соседними числами. В первом тесте мы проверили возможные варианты расположения четных чисел внутри последовательности длиной 16, во втором — варианты расположения чисел, кратных трем в такой же последовательности чисел. Выглядит разумно. А теперь напишем функцию coComposedPrimeLayouts13, которая соберет все возможные комбинации НОД-соседних чисел для всех простых НОД от 2 до 13, сортируя все элементы внутри каждой комбинации.
-- get union of all possible combinations of numbers with common prime factors
-- 2, 3, 5, 7, 11 and 13 inside an arbitrary contiguous range of s numbers
coComposedPrimeLayouts13 :: Int -> [[Int]]
coComposedPrimeLayouts13 s =
    map (sort . concat)
    [a:b:c:d:e:[f] | a <- coComposedLayouts 2  s, b <- coComposedLayouts 3  s,
                     c <- coComposedLayouts 5  s, d <- coComposedLayouts 7  s,
                     e <- coComposedLayouts 11 s, f <- coComposedLayouts 13 s]
Выглядит не очень красиво (в идеале хотелось бы обобщенную реализацию для всех простых НОД меньших s), но работает правильно: можете проверить в ghci, но вывод будет очень длинный! А вот и функция, которая находит, существует ли последовательность длиной s, удовлетворяющая условию задачи.
-- test if an arbitrary contiguous range of s numbers may have full co-composed
-- set of numbers, maximum tested prime layout is 13: this is enough for ranges
-- up to 17 numbers
hasCoComposedSet13 :: Int -> Bool
hasCoComposedSet13 s =
    elem s $ map (length . group) $ coComposedPrimeLayouts13 s
С помощью функции hasCoComposedSet13 можно доказать, что на всем множестве целых чисел не существует непрерывной последовательности длиной меньше 17, в которой для каждого числа найдется хотя бы одно другое число, не взаимно простое с исходным. А также доказать, что имеются последовательности длиной 17 чисел, для которых это условие удовлетворяется: мы находили такие последовательности с помощью функции coComposedSet 17.
map hasCoComposedSet13 [2 .. 17]
[False,False,False,False,False,False,False,False,False,False,False,False,False,False,False,True]
Теорема доказана! Исходный код программы можно найти здесь. Комментарии в строках 28–43 не верны, я не удалил их по историческим причинам. Update. Написал обобщенные версии функций coComposedPrimeLayouts и hasCoComposedSet, которые вычисляют список простых чисел, укладывающихся в заданную длину s последовательности чисел и, следовательно, подходящих для проверки существования последовательностей с искомыми свойствами произвольной длины, во время выполнения программы.
-- generalized coComposedPrimeLayouts13 with run-time calculation of
-- prime factors, requires import Data.Numbers.Primes
coComposedPrimeLayouts :: Int -> [[Int]]
coComposedPrimeLayouts s =
    map (sort . concat) $ mapM (`coComposedLayouts` s) $ takeWhile (< s) primes

--- same as hasCoComposedSet13 but uses generalized coComposedPrimeLayouts
hasCoComposedSet :: Int -> Bool
hasCoComposedSet s =
    elem s $ map (length . group) $ coComposedPrimeLayouts s
Для использования функции primes нужно подключить модуль Data.Numbers.Primes.