3
$\begingroup$

I am working on optimization of multipole magnets. Reduction of the number of possible configurations of the magnets essentially becomes the unique determination of the minimum value for all possible bit flip and bit rotation possibilities for each configuration.

For example using 2 magnets, the combinations are: 00 01 10 11

But this is only actually 2 unique combinations since 00 and 11 are the same except for a bit flip and 01 and 10 are the same except for a rotation.

The code I am using seems quite buteforce and I expect that there is a much more elegant Mathematica way to get the same results. I want to scale this to support much larger numbers of magnets.

The current code (example for 8 magnets):

(* Fixed length bit rotation function *)
SetAttributes[BitRotateRight, Listable];
BitRotateRight[n_Integer, m_Integer] /; n >= 0 && m >= 0 := BitShiftRight[n, m] + BitShiftLeft[Mod[n, 2^m], (8 - m)]

(* Fixed length bit rotation *)
rot = Table[
  Table[BitRotateRight[vals, indx], {indx, 1, 8}] // Min, {vals, 1, 
   255}]

(* Fixed length bit flip *)
xor = Table[
  Table[FromDigits[
     BitXor[1, IntegerDigits[BitRotateRight[vals, indx], 2, 8]], 
     2], {indx, 1, 8}] // Min, {vals, 1, 255}]

(* Unique set from rotations and flips *)
comb = Min[#] & /@ ({rot, xor}\[Transpose]) // DeleteDuplicates

(* Flip bit order end-to-end *)
flip = Table[
  Table[BitRotateRight[IntegerReverse[vals, 2], indx], {indx, 1, 8}] //
    Min, {vals, comb}]

(* Final reduced list - checked by hand for this case *)
(* 18 values {0, 1, 3, 5, 7, 9, 11, 15, 17, 19, 21, 23, 27, 37, 43, 45, 51, 85} *)
lst = Min[#] & /@ ({comb, flip}\[Transpose]) // DeleteDuplicates // Sort

(* Plot helper function for bit sign *)
mp = IntegerDigits[lst,2,8];

(* Plot combos *)
Table[Graphics[
  Table[{Thick, If[mp[[indx, rot]] == 0, Red, Black], 
    Arrowheads[Large], 
    Arrow[RotateLeft[{{0, 0}, 
       RotationMatrix[(rot - 1)*\[Pi]/4].{1, 1}}, 
      mp[[indx, rot]]]]}, {rot, Range[1, 8]}]], {indx, 1, 18}]

enter image description here

$\endgroup$
3
  • 1
    $\begingroup$ This appears to be a combinatorial bracelet problem in disguise. Might pursue that angle... $\endgroup$
    – ciao
    Mar 17 '20 at 23:56
  • $\begingroup$ I notice your BitRotateRight[]'s bit length is hardcoded (and apparently from here); you might want to look at the more general function here. $\endgroup$
    – J. M.'s torpor
    Mar 18 '20 at 2:03
  • $\begingroup$ @ciao, thanks. I thought that there was a name for this type of problem. $\endgroup$
    – OpticsMan
    Mar 18 '20 at 17:08
4
$\begingroup$

Too long for a comment, but this might get you into the right direction:

Block[{$ContextPath}, Quiet@Needs["Combinatorica`"];
  mp = Join @@ 
     Table[Combinatorica`ListNecklaces[8, 
       Join[ConstantArray[0, 8 - x], ConstantArray[1, x]], 
       Combinatorica`Dihedral], {x, 0, 4}] 
  ];

Table[Graphics[
   Table[{Thick, If[mp[[indx, rot]] == 0, Red, Black], 
     Arrowheads[Large], 
     Arrow[RotateLeft[{{0, 0}, 
        RotationMatrix[(rot - 1)*\[Pi]/4].{1, 1}}, 
       mp[[indx, rot]]]]}, {rot, Range[1, 8]}]], {indx, 1, 
   Length@mp}] // Row

Note that the result corresponds to your result, up to order, with the addition of one element (the 15th below) which when looking at your result I thought should be a valid element, but it's a bit-flipped copy. This perhaps can be of use nonetheless to either reduce the search space for "duplicates", or even adapting the code in the Combinatorica package to your precise needs.

enter image description here

$\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.