Menu
In combinatorial mathematics, a Langford pairing, also called a Langford sequence, is a permutation of the sequence of 2n numbers 1, 1, 2, 2, ..., n,n in which the two ones are one unit apart, the two twos are two units apart, and more generally the two copies of each number k are k units apart.
For example:
Langford pairing for n = 3 is given by the sequence 2,3,1,2,1,3.
haskell or C
--------------------------EDIT----------------------
How could we define the mathematical rules to put @Rafe's code in haskell
772
You want to find an assignment to the variables {p1, p2, ..., pn} (where pi is the position of the first occurrence of 'i') with the following constraints holding for each pi:
You need a sensible search strategy here. A good choice is to at each choice point choose the pi with the smallest remaining set of possible values.
Cheers!
[EDIT: second addendum.]
This is a "mostly functional" version of the imperative version I first wrote (see first addendum below). It's mostly functional in the sense that the state associated with each vertex in the search tree is independent of all other state, hence there's no need for a trail or machinery of that kind. However, I have used imperative code to implement the construction of each new domain set from a copy of the parent domain set.
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();
}
}
}
[EDIT: first addendum.]
I decided to write a C# program to solve Langford problems. It runs very quickly up to n = 16, but thereafter you need to change it to use longs since it represents domains as bit patterns.
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;
}
}
}
}
I couldn't resist. Here's my port of Rafe's code to 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)]
It seems to work quite well. Here are some timings from 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)
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With
