7
$\begingroup$

I need to sum over all possible permutations, multiplied by the Signature of each permutation of a given list of symbols. But, I don't know how to determine the Signature of each particular permutation with respect to the original given list (because the original input list may not be in canonical order).

Here's my code that does the job without including the appropriate minus signs:

input = {b, a, c};
Total[Map[(*signature factor here*)function[#] &, Permutations[input]]]

(*function[{a, b, c}] + function[{a, c, b}] + function[{b, a, c}] + 
  function[{b, c, a}] + function[{c, a, b}] + function[{c, b, a}]*)

  1. How do I include the appropriate minus sign? For input={b, a, c} The output should be:

    (* -function[{a, b, c}] + function[{a, c, b}] + function[{b, a, c}] - 
      function[{b, c, a}] - function[{c, a, b}] + function[{c, b, a}]*)
    

    For input={a, b, c} , the output should be

    (* function[{a, b, c}] - function[{a, c, b}] - function[{b, a, c}] + 
      function[{b, c, a}] + function[{c, a, b}] - function[{c, b, a}]*)
    
  2. Also, since input may be large, is it possible to get the signature during runtime (of Permutations) for higher performance?

$\endgroup$
  • $\begingroup$ Closely related: (60111) $\endgroup$ – Mr.Wizard Oct 27 '14 at 15:53
  • $\begingroup$ @Mr.Wizard Sorry it took a while; I wanted to be fair about which answer I found to be most useful... $\endgroup$ – QuantumDot Nov 2 '14 at 9:41
2
$\begingroup$

Applying the method I described in: How to define even permutations correctly?:

fW[a_List] :=
  With[{p = Permutations @ Range @ Length @ a},
    Dot[Signature /@ p, func /@ Extract[a, p ~Partition~ 1]]
  ]

This is faster than both of kguler's functions (which are in turn faster than belisarius's code):

f1 = Function[{k}, Total[Map[Signature[ #[[Ordering @ k]] ] func[#] &, Permutations[k]]]];
f2 = Function[{k}, Total[Map[Signature[#] Signature[k] func[#] &, Permutations[k]]]];

(res1 = f1 /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First

(res2 = f2 /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First

(resW = fW /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First

Equal @@ {res1, res2, resW}
2.290631

2.320133

1.121564

True

Note: my code uses an undocumented syntax for Extract which works in Mathematica 8 or later. If you have an earlier version please use:

fW[a_List] :=
  With[{p = Permutations @ Range @ Length @ a},
    Dot[Signature /@ p, func /@ (a[[#]] & /@ p)]
  ]
|improve this answer|||||
$\endgroup$
6
$\begingroup$
input = {b, a, c};

Perhaps

Total[Map[Signature[ #[[Ordering @ input]] ] func[#] &, Permutations[input]]]
(* -func[{a, b, c}] + func[{a, c, b}] + func[{b, a, c}] - 
    func[{b, c, a}] - func[{c, a, b}] + func[{c, b, a}] *)

or

Total[Map[Signature[#]Signature[input] func[#] &, Permutations[input]]]
(* same result *)

or

Signature[input] Total[Map[Signature[#] func[#] &, Permutations[input]]]
(* same result *)

Function[{k}, {Row@k, Total[Map[Signature[ #[[Ordering @ k]] ] func[#] &,
      Permutations[k]]]}] /@ Permutations[{a, b, c}] // TableForm

enter image description here

Timing comparisons:

f1 = Function[{k},Total[Map[Signature[ #[[Ordering @ k]] ] func[#] &, Permutations[k]]]];
f2 = Function[{k},Total[Map[Signature[#] Signature[k] func[#] &, Permutations[k]]]];
f3 = Function[{k},Signature[k] Total[Map[Signature[#]  func[#] &, Permutations[k]]]];
fB = Function[{k},Total[Map[Signature[# /. mapping[k]] func[#] &, Permutations[k]]]];
fW[a_List] := With[{p = Permutations @ Range @ Length @ a},
              Dot[Signature /@ p, func /@ Extract[a, p ~Partition~ 1]] ];

All permutations of length 5 and 6:

(res1 = f1 /@ Permutations[{a, b, c, d, e}] ); // AbsoluteTiming // First
(* 0.062501 *)
(res2 = f2 /@ Permutations[{a, b, c, d, e}] ); //AbsoluteTiming // First
(* 0.061893 *)
(res3 = f3 /@ Permutations[{a, b, c, d, e}] ); // AbsoluteTiming // First
(resB = fB /@ Permutations[{a, b, c, d, e}] ); // AbsoluteTiming // First
(* 0.171893 *)
(resW = fW /@ Permutations[{a, b, c, d, e}] ); // AbsoluteTiming // First
Equal @@ {res1, res2, res3, resB, resW}
(* True *)

(res1 = f1 /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First
(* 2.245413 *)
(res2 = f2 /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First
(* 2.410684 *)
(res3 = f3 /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First
(* 1.674195 *)
(resB = fB /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First
(* 7.132036 *)
(resW = fW /@ Permutations[{a, b, c, d, e, x}]); // AbsoluteTiming // First
(* 1.101775 *)
Equal @@ {res1, res2, res3, resB, resW}
(* True *)

Random permutations of length 9 and 10:

rp = PermutationList[RandomPermutation[9], 9];
(res1 = f1@rp); // AbsoluteTiming // First
(* 2.332165 *)
(res2 = f2@rp); // AbsoluteTiming // First
(* 2.111594 *)
(res3 = f3@rp); // AbsoluteTiming // First
(* 2.024557 *)
(resB = fB@rp); // AbsoluteTiming // First
(* 7.328174 *)
(resW = fW@rp); // AbsoluteTiming // First
(* 2.007417 *)
Equal @@ {res1, res2, res3, resB, resW}
(*True*)

rp = PermutationList[RandomPermutation[10], 10];
(res1 = f1@rp); // AbsoluteTiming // First
(* 24.681737 *)
(res2 = f2@rp); // AbsoluteTiming // First
(* 22.776874 *)
(res3 = f3@rp); // AbsoluteTiming // First
(* 20.031120 *)
(resB = fB@rp); // AbsoluteTiming // First
(* 78.861839 *)
(resW = fW@rp); // AbsoluteTiming // First
(* 21.637332 *)
Equal @@ {res1, res2, res3, resB, resW}
(*True*)
|improve this answer|||||
$\endgroup$
  • $\begingroup$ Oops, I forgot to clarify that input is an arbitrary list of symbols. Thus, I can't hard-code the minus sign. e.g If input={a,b,c} then the sign in front of f[{a,b,c}] should be +1 (I have edited the question to clarify this). $\endgroup$ – QuantumDot Oct 27 '14 at 13:03
  • $\begingroup$ @QuantumDot, could you please check if the updated post works as you expect? $\endgroup$ – kglr Oct 27 '14 at 13:47
  • $\begingroup$ Yes this works very nicely! Many thanks for your help. $\endgroup$ – QuantumDot Oct 27 '14 at 14:05
  • $\begingroup$ I slightly modified your code formatting in the interest of readability. I hope you approve. $\endgroup$ – Mr.Wizard Oct 27 '14 at 15:57
3
$\begingroup$
mapping[set_] := Dispatch@Thread[set -> Range@Length@set]
input = {a, b, c};
Total[Map[Signature[# /. mapping[input]] function[#] &, Permutations[input]]]

(* function[{a, b, c}] - function[{a, c, b}] - function[{b, a, c}] + 
   function[{b, c, a}] + function[{c, a, b}] - function[{c, b, a}]*)
|improve this answer|||||
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.