Реализация последовательности Лэнгфорда на Haskell или C

Question

В комбинаторной математике спаривание Лэнгфорда , также называемое последовательностью Лэнгфорда, представляет собой перестановку последовательности 2n чисел 1, 1, 2, 2, ..., n, n, в которой два находятся на расстоянии одной единицы, двапо две единицы друг от друга, и в более общем случае две копии каждого числа k разделены на k единиц.

Например:

Спаривание Лэнгфорда для n = 3 задается последовательностью 2,3,1,2,1,3.

• Какой хороший метод для решения этой проблемы в haskell или C
• Можете ли вы предложить алгоритм для его решения (не хотите использовать грубую силу)?

-------------------------- РЕДАКТИРОВАТЬ ----------------------
Как определить математические правила для помещения кода @ Rafe в haskell

Answer 1

Вы хотите найти присваивание переменным {p1, p2, ..., pn} (где pi - позиция первого вхождения 'i') со следующими ограничениями, удерживающими для каждого pi:

• пи в 1 .. (1 + н-я)
• если pi = k, тогда все pj, где j! = I
• pj! = K
• pj! = K + i
• pj! = K - j
• pj! = K + i - j

Вам нужна разумная стратегия поиска здесь. Хороший выбор состоит в том, чтобы в каждой точке выбора выбирать пи с наименьшим оставшимся набором возможных значений.

Ура!

[ПРАВКА: второе дополнение.]

Это «в основном функциональная» версия императивной версии, которую я впервые написал (см. Первое приложение ниже). Он в основном функционален в том смысле, что состояние, связанное с каждой вершиной в дереве поиска, не зависит от всех других состояний, поэтому нет необходимости в следе или механизме такого рода. Тем не менее, я использовал императивный код для реализации построения каждого нового набора доменов из копии набора родительских доменов.

using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;

namespace MostlyFunctionalLangford
{
    class Program
    {
        // An (effectively functional) program to compute Langford sequences.
        static void Main(string[] args)
        {
            var n = 7;
            var DInit = InitLangford(n);
            var DSoln = Search(DInit);
            if (DSoln != null)
            {
                Console.WriteLine();
                Console.WriteLine("Solution for n = {0}:", n);
                WriteSolution(DSoln);
            }
            else
            {
                Console.WriteLine();
                Console.WriteLine("No solution for n = {0}.", n);
            }
            Console.Read();
        }

        // The largest integer in the Langford sequence we are looking for.
        // [I could infer N from the size of the domain array, but this is neater.]
        static int N;

        // ---- Integer domain manipulation. ----

        // Find the least bit in a domain; return 0 if the domain is empty.
        private static long LeastBitInDomain(long d)
        {
            return d & ~(d - 1);
        }

        // Remove a bit from a domain.
        private static long RemoveBitFromDomain(long d, long b)
        {
            return d & ~b;
        }

        private static bool DomainIsEmpty(long d)
        {
            return d == 0;
        }

        private static bool DomainIsSingleton(long d)
        {
            return (d == LeastBitInDomain(d));
        }

        // Return the size of a domain.
        private static int DomainSize(long d)
        {
            var size = 0;
            while (!DomainIsEmpty(d))
            {
                d = RemoveBitFromDomain(d, LeastBitInDomain(d));
                size++;
            }
            return size;
        }

        // Find the k with the smallest non-singleton domain D[k].
        // Returns zero if none exists.
        private static int SmallestUndecidedDomainIndex(long[] D)
        {
            var bestK = 0;
            var bestKSize = int.MaxValue;
            for (var k = 1; k <= N && 2 < bestKSize; k++)
            {
                var kSize = DomainSize(D[k]);
                if (2 <= kSize && kSize < bestKSize)
                {
                    bestK = k;
                    bestKSize = kSize;
                }
            }
            return bestK;
        }

        // Obtain a copy of a domain.
        private static long[] CopyOfDomain(long[] D)
        {
            var DCopy = new long[N + 1];
            for (var i = 1; i <= N; i++) DCopy[i] = D[i];
            return DCopy;
        }

        // Destructively prune a domain by setting D[k] = {b}.
        // Returns false iff this exhausts some domain.
        private static bool Prune(long[] D, int k, long b)
        {
            for (var j = 1; j <= N; j++)
            {
                if (j == k)
                {
                    D[j] = b;
                }
                else
                {
                    var dj = D[j];
                    dj = RemoveBitFromDomain(dj, b);
                    dj = RemoveBitFromDomain(dj, b << (k + 1));
                    dj = RemoveBitFromDomain(dj, b >> (j + 1));
                    dj = RemoveBitFromDomain(dj, (b << (k + 1)) >> (j + 1));
                    if (DomainIsEmpty(dj)) return false;
                    if (dj != D[j] && DomainIsSingleton(dj) && !Prune(D, j, dj)) return false;
                }
            }
            return true;
        }

        // Search for a solution from a given set of domains.
        // Returns the solution domain on success.
        // Returns null on failure.
        private static long[] Search(long[] D)
        {
            var k = SmallestUndecidedDomainIndex(D);
            if (k == 0) return D;

            // Branch on k, trying each possible assignment.
            var dk = D[k];
            while (!DomainIsEmpty(dk))
            {
                var b = LeastBitInDomain(dk);
                dk = RemoveBitFromDomain(dk, b);
                var DKeqB = CopyOfDomain(D);
                if (Prune(DKeqB, k, b))
                {
                    var DSoln = Search(DKeqB);
                    if (DSoln != null) return DSoln;
                }
            }

            // Search failed.
            return null;
        }

        // Set up the problem.
        private static long[] InitLangford(int n)
        {
            N = n;
            var D = new long[N + 1];
            var bs = (1L << (N + N - 1)) - 1;
            for (var k = 1; k <= N; k++)
            {
                D[k] = bs & ~1;
                bs >>= 1;
            }
            return D;
        }

        // Print out a solution.
        private static void WriteSolution(long[] D)
        {
            var l = new int[N + N + 1];
            for (var k = 1; k <= N; k++)
            {
                for (var i = 1; i <= N + N; i++)
                {
                    if (D[k] == 1L << i)
                    {
                        l[i] = k;
                        l[i + k + 1] = k;
                    }
                }
            }
            for (var i = 1; i < l.Length; i++)
            {
                Console.Write("{0} ", l[i]);
            }
            Console.WriteLine();
        }
    }
}

[ПРАВКА: первое добавление.]

Я решил написать программу на C # для решения проблем Лэнгфорда. Он работает очень быстро до n = 16, но после этого вам нужно изменить его на использование long, поскольку он представляет домены в виде битовых комбинаций.

using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;

namespace Langford
{
    // Compute Langford sequences.  A Langford sequence L(n) is a permutation of [1, 1, 2, 2, ..., n, n] such
    // that the pair of 1s is separated by 1 place, the pair of 2s is separated by 2 places, and so forth.
    //
    class Program
    {
        static void Main(string[] args)
        {
            var n = 16;
            InitLangford(n);
            WriteDomains();
            if (FindSolution())
            {
                Console.WriteLine();
                Console.WriteLine("Solution for n = {0}:", n);
                WriteDomains();
            }
            else
            {
                Console.WriteLine();
                Console.WriteLine("No solution for n = {0}.", n);
            }
            Console.Read();
        }

        // The n in L(n).
        private static int N;

        // D[k] is the set of unexcluded possible positions in the solution of the first k for each pair of ks.
        // Each domain is represented as a bit pattern, where bit i is set iff i is in D[k].
        private static int[] D;

        // The trail records domain changes to undo on backtracking.  T[2k] gives the element in D to undo;
        // T[2k+1] gives the value to which it must be restored.
        private static List<int> T = new List<int> { };

        // This is the index of the next unused entry in the trail.
        private static int TTop;

        // Extend the trail to restore D[k] on backtracking.
        private static void TrailDomainValue(int k)
        {
            if (TTop == T.Count)
            {
                T.Add(0);
                T.Add(0);
            }
            T[TTop++] = k;
            T[TTop++] = D[k];
        }

        // Undo the trail to some earlier point.
        private static void UntrailTo(int checkPoint)
        {
            //Console.WriteLine("Backtracking...");

            while (TTop != checkPoint)
            {
                var d = T[--TTop];
                var k = T[--TTop];
                D[k] = d;
            }
        }

        // Find the least bit in a domain; return 0 if the domain is empty.
        private static int LeastBitInDomain(int d)
        {
            return d & ~(d - 1);
        }

        // Remove a bit from a domain.
        private static int RemoveBitFromDomain(int d, int b)
        {
            return d & ~b;
        }

        private static bool DomainIsEmpty(int d)
        {
            return d == 0;
        }

        private static bool DomainIsSingleton(int d)
        {
            return (d == LeastBitInDomain(d));
        }

        // Return the size of a domain.
        private static int DomainSize(int d)
        {
            var size = 0;
            while (!DomainIsEmpty(d))
            {
                d = RemoveBitFromDomain(d, LeastBitInDomain(d));
                size++;
            }
            return size;
        }

        // Find the k with the smallest non-singleton domain D[k].
        // Returns zero if none exists.
        private static int SmallestUndecidedDomainIndex()
        {
            var bestK = 0;
            var bestKSize = int.MaxValue;
            for (var k = 1; k <= N && 2 < bestKSize; k++)
            {
                var kSize = DomainSize(D[k]);
                if (2 <= kSize && kSize < bestKSize)
                {
                    bestK = k;
                    bestKSize = kSize;
                }
            }
            return bestK;
        }

        // Prune the other domains when domain k is reduced to a singleton.
        // Return false iff this exhausts some domain.
        private static bool Prune(int k)
        {
            var newSingletons = new Queue<int>();
            newSingletons.Enqueue(k);

            while (newSingletons.Count != 0)
            {
                k = newSingletons.Dequeue();

                //Console.WriteLine("Pruning from domain {0}.", k);

                var b = D[k];
                for (var j = 1; j <= N; j++)
                {
                    if (j == k) continue;
                    var dOrig = D[j];
                    var d = dOrig;
                    d = RemoveBitFromDomain(d, b);
                    d = RemoveBitFromDomain(d, b << (k + 1));
                    d = RemoveBitFromDomain(d, b >> (j + 1));
                    d = RemoveBitFromDomain(d, (b << (k + 1)) >> (j + 1));
                    if (DomainIsEmpty(d)) return false;
                    if (d != dOrig)
                    {
                        TrailDomainValue(j);
                        D[j] = d;
                        if (DomainIsSingleton(d)) newSingletons.Enqueue(j);
                    }
                }

                //WriteDomains();
            }
            return true;
        }

        // Search for a solution.  Return false iff one is not found.
        private static bool FindSolution() {
            var k = SmallestUndecidedDomainIndex();
            if (k == 0) return true;

            // Branch on k, trying each possible assignment.
            var dOrig = D[k];
            var d = dOrig;
            var checkPoint = TTop;
            while (!DomainIsEmpty(d))
            {
                var b = LeastBitInDomain(d);
                d = RemoveBitFromDomain(d, b);
                D[k] = b;

                //Console.WriteLine();
                //Console.WriteLine("Branching on domain {0}.", k);

                if (Prune(k) && FindSolution()) return true;
                UntrailTo(checkPoint);
            }
            D[k] = dOrig;
            return false;
        }

        // Print out a representation of the domains.
        private static void WriteDomains()
        {
            for (var k = 1; k <= N; k++)
            {
                Console.Write("D[{0,3}] = {{", k);
                for (var i = 1; i <= N + N; i++)
                {
                    Console.Write("{0, 3}", ( (1 << i) & D[k]) != 0 ? i.ToString() 
                                            : DomainIsSingleton(D[k]) && (1 << i) == (D[k] << (k + 1)) ? "x"
                                            : "");
                }
                Console.WriteLine(" }");
            }
        }

        // Set up the problem.
        private static void InitLangford(int n)
        {
            N = n;
            D = new int[N + 1];
            var bs = (1 << (N + N - 1)) - 1;
            for (var k = 1; k <= N; k++)
            {
                D[k] = bs & ~1;
                bs >>= 1;
            }
        }
    }
}

Answer 2

Я не мог устоять. Вот мой порт кода Рэйфа в Haskell:

module Langford where

import Control.Applicative
import Control.Monad
import Data.Array
import Data.List
import Data.Ord
import Data.Tuple
import qualified Data.IntSet as S

langford :: Int -> [[Int]]
langford n
  | mod n 4 `elem` [0, 3] = map (pairingToList n) . search $ initial n
  | otherwise             = []

type Variable = (Int, S.IntSet)
type Assignment = (Int, Int)
type Pairing = [Assignment]

initial :: Int -> [Variable]
initial n = [(i, S.fromList [1..(2*n-i-1)]) | i <- [1..n]]

search :: [Variable] -> [Pairing]
search [] = return []
search vs = do
    let (v, vs') = choose vs
    a <- assignments v
    case prune a vs' of
        Just vs'' -> (a :) <$> search vs''
        Nothing   -> mzero

choose :: [Variable] -> (Variable, [Variable])
choose vs = (v, filter (\(j, _) -> i /= j) vs)
  where v@(i, _) = minimumBy (comparing (S.size . snd)) vs

assignments :: Variable -> [Assignment]
assignments (i, d) = [(i, k) | k <- S.toList d]

prune :: Assignment -> [Variable] -> Maybe [Variable]
prune a = mapM (prune' a)

prune' :: Assignment -> Variable -> Maybe Variable
prune' (i, k) (j, d)
  | S.null d' = Nothing
  | otherwise = Just (j, d')
  where d' = S.filter (`notElem` [k, k+i+1, k-j-1, k+i-j]) d

pairingToList :: Int -> Pairing -> [Int]
pairingToList n = elems . array (1, 2*n) . concatMap positions
  where positions (i, k) = [(k, i), (k+i+1, i)]

Кажется, это работает довольно хорошо. Вот некоторые моменты из GHCi:

Prelude Langford> :set +s
Prelude Langford> head $ langford 4
[4,1,3,1,2,4,3,2]
(0.03 secs, 6857080 bytes)
Prelude Langford> head $ langford 32
[32,28,31,23,26,29,22,24,27,15,17,11,25,10,30,5,20,2,21,19,2,5,18,11,10, ...]
(0.05 secs, 15795632 bytes)
Prelude Langford> head $ langford 100
[100,96,99,91,94,97,90,92,95,83,85,82,93,78,76,73,88,70,89,87,69,64,86, ...]
(0.57 secs, 626084984 bytes)

Answer 3

Поскольку последовательности Лэнгфорда обычно генерируются для небольшого целого числа n , я использую bogosort для этой программы и включаю проверку каждый раз, когда она bogosorted.Когда проверка завершится, я закончу.

Например, с n = 3:

• Создать массив для 2n чисел.Массив будет выглядеть примерно так: 1 2 3 1 2 3
• Использовать простой цикл для bogosort и включать проверку каждый раз, что довольно просто.
• Если проверка прошла успешно, массив выдастВы - последовательность Лэнгфорда.

Это будет работать быстро только для небольших целых чисел, поскольку число возможных перестановок равно n! , здесь: 3 * 2 * 1 = 6.