Ничего действительно нового здесь, то же решение @Kevin уже выложено, но я думаю, интересно посмотреть, как оно переводится на функциональный язык. В этом случае Mathematica :
Extract[#,Position[Times @@ (Abs@#-1)&/@ Differences/@ #, Except@0, 1][[2 ;;]]]
&@ Permutations@Range@5
Некоторые объяснения:
Permutations@Range@5 Calculates all permutations of {1, 2, 3, 4, 5}
Differences Calculate the differences between adjacent elements
(we wish to discard all lists containing +1 or -1)
Times @@ (Abs@#-1) Abs turns the -1s into +1s, and then to zeros by subtracting
one, then TIMES multiplies all elements, giving zero when
the original result of "Differences" contained a +1 or a -1
Position ... Except@0 Returns the position of the non zero results
Extract Returns the original elements according to the calculated
positions
Окончательный результат:
{{1, 3, 5, 2, 4}, {1, 4, 2, 5, 3}, {2, 4, 1, 3, 5}, {2, 4, 1, 5, 3},
{2, 5, 3, 1, 4}, {3, 1, 4, 2, 5}, {3, 1, 5, 2, 4}, {3, 5, 1, 4, 2},
{3, 5, 2, 4, 1}, {4, 1, 3, 5, 2}, {4, 2, 5, 1, 3}, {4, 2, 5, 3, 1},
{5, 2, 4, 1, 3}, {5, 3, 1, 4, 2}}
Редактировать
Или, более сложно объяснить, но короче:
Reap[ Table[ If[Times @@ (Abs@Differences@i - 1) != 0, Sow@i],
{i, Permutations@Range@5}]][[2, 1]]