Langford 序列实现 Haskell 或 C

Question

在组合数学中，兰福德配对，也称为兰福德序列，是以下序列的排列： 2n 数字 1, 1, 2, 2, ..., n,n 其中两个 1 相距 1 个单位，两个 2 相距 2 个单位，并且更一般地，每个数字 k 的两个副本相距 k 个单位。

例如：

n = 3 的 Langford 配对由序列 2,3,1,2,1,3 给出。

• 解决这个问题的好方法是什么 < code>haskell 或 C
• 你能建议一种算法来解决它（不想使用暴力）吗？

------------------------编辑-------------------- --
我们如何定义数学规则以将 @Rafe 的代码放入 haskell 中

Answer 1

您想要找到对变量 {p1, p2, ..., pn} 的赋值（其中 pi 是第一次出现“i”的位置），并且每个 pi 都遵循以下约束：

• pi in 1..( 1+ni)
• if pi = k then forall pj where j != i
• pj != k
• pj != k + i
• pj != k - j
• pj != k + i - j

你需要一个合理的搜索策略 这里。一个好的选择是在每个选择点选择具有最小剩余可能值集的 pi。

干杯!

[编辑：第二个附录。]

这是我第一次编写的命令式版本的“主要功能”版本（请参阅下面的第一个附录）。它主要是功能性的，因为与搜索树中每个顶点相关的状态独立于所有其他状态，因此不需要这种类型的踪迹或机制。但是，我使用命令式代码来实现从父域集的副本构建每个新域集。

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# 程序来解决 Langford 问题。它运行得非常快，直到 n = 16，但此后您需要将其更改为使用长整型，因为它将域表示为位模式。

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

我无法抗拒。这是我将 Rafe 的代码移植到 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 :) <
gt; 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

由于 Langford 序列通常是为小整数 n 生成的，因此我在该程序中使用 bogosort，并在每次进行 bogosort 时都包含一个检查。当检查完成时，我就完成了。

例如，n=3：

• 为 2n 个数字创建一个数组。该数组将是这样的： 1 2 3 1 2 3
• 对 bogosort 使用一个简单的循环，并每次都包含一个检查，这非常容易。
• 如果检查成功，数组将为您提供兰福德序列。

仅对于小整数，这才可以快速工作，因为可能的排列数量为 n!，此处：3*2*1=6。