Efficiently generating "subtraction chains" - algorithm

I posted another question earlier if you want some context. It appears that I was on the wrong path with that approach.
Addition chains can be used to minimize the number of multiplications needed to exponentiate a number. For example, a7 requires four multiplications. Two to compute a2=a×a and a4=a2×a2, and another two to compute a7=a4×a2×a.
Similarly, I'm trying to generate all of the possible "subtraction chains" for a set of numbers. For example, given the set of numbers {1, 2, 3}, I'm trying to generate the following permutations.
{1, 2, 3}
{1, 2, 3}, {1, 2}
{1, 2, 3}, {1, 2}, {1}
{1, 2, 3}, {1, 2}, {2}
{1, 2, 3}, {1, 2}, {1}, {2}
{1, 2, 3}, {1, 3}
{1, 2, 3}, {1, 3}, {1}
{1, 2, 3}, {1, 3}, {3}
{1, 2, 3}, {1, 3}, {1}, {3}
{1, 2, 3}, {2, 3}
{1, 2, 3}, {2, 3}, {2}
{1, 2, 3}, {2, 3}, {3}
{1, 2, 3}, {2, 3}, {2}, {3}
{1, 2, 3}, {1, 2}, {1, 3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}
{1, 2, 3}, {1, 2}, {1, 3}, {2}
{1, 2, 3}, {1, 2}, {1, 3}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {2}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {2}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {2}, {3}
# and so on...
Where each element in the permutation (besides {1, 2, 3}) can be found by removing a single element from another set in the permutation.
For example, the permutation {1, 2, 3}, {1} is invalid because {1} can not be constructed by removing a single element from {1, 2, 3}.
Is there a known algorithm to find this subset of the power set of a power set? My implementation will be in Python, but the question is language agnostic. Also, I don't actually want the permutations which contain a set with a single element (e.g. {1, 2, 3}, {1, 2}, {1}) because they corresponds to a "dictator" case which is not of interest.

An algorithm to generate all those lists as you describe it could work as follows: For each set in the current list, create a copy, remove one element, add it to the list, and call the algorithm recursively. You also have to make sure not to generate duplicates, which could by done by ensuring that the new list is "smaller" (by length or pairwise comparison of the (sorted) elements) than the previous one.
Here's an implementation in Python, as a generator function, without much optimization. This seems to work pretty well now, generating all the subsets without any duplicates.
def generate_sets(sets, min_num=2):
yield sets
added = set() # new sets we already generated in this iteration
for set_ in sets:
# only if the current set has the right length
if min_num < len(set_) <= len(sets[-1]) + 1:
for x in set_:
# remove each element in turn (frozenset so we can put in into added)
new = set_.difference({x})
# prevent same subset being reachable form multiple sets
frozen = frozenset(new)
if frozen not in added:
added.add(frozen)
# recurse only if current element is "smaller" than last
if (len(new), sorted(new)) < (len(sets[-1]), sorted(sets[-1])):
for result in generate_sets(sets + [new], min_num):
yield result
For generate_sets([{1,2,3}], min_num=2) this generates the following lists:
[{1, 2, 3}]
[{1, 2, 3}, {2, 3}]
[{1, 2, 3}, {2, 3}, {1, 3}]
[{1, 2, 3}, {2, 3}, {1, 3}, {1, 2}]
[{1, 2, 3}, {2, 3}, {1, 2}]
[{1, 2, 3}, {1, 3}]
[{1, 2, 3}, {1, 3}, {1, 2}]
[{1, 2, 3}, {1, 2}]
For generate_sets([{1,2,3}], 1), a total of 45 lists of sets are generated.
However, I fail to see the connection to your previous question: Shouldn't {1, 2, 3}, {1, 2}, {1, 2, 3}, {1, 3}, and {1, 2, 3}, {2, 3} all be considered equivalent?

Related

loop to generate iterative rows of a matrix in mathematica

I have a matrix
FT= {{0, 0, 0}, {1, 1, 1}, {1, 1, 2}, {1, 1, 3}, {1, 2, 1}, {1, 2, 2}, {1,
2, 3}, {1, 3, 1}, {1, 3, 2}, {1, 3, 3}, {2, 1, 1}, {2, 1, 2}, {2,
1, 3}, {2, 2, 1}, {2, 2, 2}, {2, 2, 3}, {2, 3, 1}, {2, 3, 2}, {2, 3,
3}, {2, 4, 1}, {2, 4, 2}, {2, 4, 3}, {2, 5, 1}, {2, 5, 2}, {2, 5,
3}, {2, 6, 1}, {2, 6, 2}, {2, 6, 3}, {3, 1, 1}, {3, 1, 2}, {3, 1,
3}, {3, 2, 1}, {3, 2, 2}, {3, 2, 3}, {3, 3, 1}, {3, 3, 2}, {3, 3,
3}, {3, 4, 1}, {3, 4, 2}, {3, 4, 3}, {3, 5, 1}, {3, 5, 2}, {3, 5,
3}, {3, 6, 1}, {3, 6, 2}, {3, 6, 3}, {3, 7, 1}, {3, 7, 2}, {3, 7,
3}, {3, 8, 1}, {3, 8, 2}, {3, 8, 3}, {3, 9, 1}, {3, 9, 2}, {3, 9,
3}, {3, 10, 1}, {3, 10, 2}, {3, 10, 3}, {3, 11, 1}, {3, 11, 2}, {3,
11, 3}, {3, 12, 1}, {3, 12, 2}, {3, 12, 3}}
Where each row represents a kind of address of each element whose first element gives G, second element gives B and the third element gives M. For e.g. for 3rd element G is 1, B is 1 and M is 2 and so on. Now i need to generate a matrix for each element such that whenever my G is 0 or 1 it gives me {0,0,0} and for G>1 it gives me rows with G-1, G-2 and so on till it gives 1; and for B it gives a check for whenever B is even it returns B/2 and whenever B is odd it returns (B+1) /2 and M takes value of 3 every time and finally a row {0,0,0}. For e.g. for last element with FT= {3,12,3} it should give me {{2,6,3}, {1,3,3}, {0,0,0}} and for FT= {2,5,1} it should give me {{1,3,3}, {0,0,0}}.
Can you please help me writing code for this in mathematica.
Thanks in advance :)
For this demo lower-case symbols are used to avoid conflicting with built-in functions, e.g. D, E, I, N
This function defines the basic operation
op[{g_, b_, m_}] := {g - 1, If[EvenQ[b], b/2, (b + 1)/2], 3}
which should be applied repeatedly until a condition is met. NestWhileList is useful for this, e.g.
NestWhileList[op[#] &, {3, 12, 3}, First[#] > 1 &]
{{3, 12, 3}, {2, 6, 3}, {1, 3, 3}}
Another function uses the above if g > 1 :-
f[{g_, b_, m_}] := Append[
If[g > 1, Rest#NestWhileList[op, {g, b, m}, First[#] > 1 &],
{}], {0, 0, 0}]
E.g.
f[{2, 5, 1}]
{{1, 3, 3}, {0, 0, 0}}
Now f can be mapped over ft :-
ft = {
{0, 0, 0}, {1, 1, 1}, {1, 1, 2}, {1, 1, 3}, {1, 2, 1},
{1, 2, 2}, {1, 2, 3}, {1, 3, 1}, {1, 3, 2}, {1, 3, 3},
{2, 1, 1}, {2, 1, 2}, {2, 1, 3}, {2, 2, 1}, {2, 2, 2},
{2, 2, 3}, {2, 3, 1}, {2, 3, 2}, {2, 3, 3}, {2, 4, 1},
{2, 4, 2}, {2, 4, 3}, {2, 5, 1}, {2, 5, 2}, {2, 5, 3},
{2, 6, 1}, {2, 6, 2}, {2, 6, 3}, {3, 1, 1}, {3, 1, 2},
{3, 1, 3}, {3, 2, 1}, {3, 2, 2}, {3, 2, 3}, {3, 3, 1},
{3, 3, 2}, {3, 3, 3}, {3, 4, 1}, {3, 4, 2}, {3, 4, 3},
{3, 5, 1}, {3, 5, 2}, {3, 5, 3}, {3, 6, 1}, {3, 6, 2},
{3, 6, 3}, {3, 7, 1}, {3, 7, 2}, {3, 7, 3}, {3, 8, 1},
{3, 8, 2}, {3, 8, 3}, {3, 9, 1}, {3, 9, 2}, {3, 9, 3},
{3, 10, 1}, {3, 10, 2}, {3, 10, 3}, {3, 11, 1}, {3, 11, 2},
{3, 11, 3}, {3, 12, 1}, {3, 12, 2}, {3, 12, 3}};
matrix = Map[f, ft]

Mathematica, group pairs with common values

I'm trying to use the GatherBy function in Mathematica in order to take the pairs in the list a={{1, 4}, {2, 3}, {1, 5}, {2, 5}, {3, 4}, {6, 8}, {6, 7}, {7, 8}} and sort by the pairs that contain the value 1. Ideally, output would look like Output={ { {1,4},{1,5} } , {{2, 3}, {2, 5}, {3, 4}, {6, 8}, {6, 7}, {7, 8} } } or something similar where the first element in the output is a list of all elements in a containing a 1 and the second element contains all pairs that do not contain a 1.
GatherBy[a, #[[1]] == 1 || #[[2]] == 1 &]
answering the q in the comment, Sort the result to ensure the desired order:
a = {{1, 4}, {2, 3}, {1, 5}, {2, 5}, {3, 4}, {6, 8}, {6, 7}, {7, 8}};
SortBy[GatherBy[a, MemberQ[#, 2] &], !MemberQ[First##, 2] &]
another approach :
Reap[Sow[ # , MemberQ[#, 2] ] & /# a, {True, False}] // Last
Either yields:
{{{{2, 3}, {2, 5}}}, {{{1, 4}, {1, 5}, {3, 4}, {6, 8}, {6, 7}, {7,
8}}}}

How to trace a path graphically in a matrix in mathematica

I have a matrix, i.e., a non-ragged list of lists, and given a list of coordinates, for example in form of {{0,0},{1,1},{2,2},...{5,5}}, I want to trace a path in that matrix and show the results graphically. A colored band for the path is good enough.
Please help me to write such a function in Mathematica. Thanks a lot!
Here's one possibility.
pos = {{1, 1}, {1, 2}, {2, 2}, {3, 3},
{3, 4}, {3, 5}, {4, 5}, {5, 5}};
mat = HankelMatrix[8];
display = Map[Pane[#,{16,20},Alignment->Center]&, mat, {2}];
display = MapAt[Style[#, Background -> Yellow]&, display, pos];
Grid[display, Spacings->{0,0}]
Outlining the entries with a tube, as you describe, is harder. It can be done, though, if we are willing to step down to graphics primitives.
mat = IdentityMatrix[8];
pos = {{1, 1}, {1, 2}, {2, 2}, {3, 3},
{3, 4}, {3, 5}, {4, 5}, {5, 5}};
pos = Map[{#[[1]], -#[[2]]} &, pos];
outline = {CapForm["Round"], JoinForm["Round"],
{AbsoluteThickness[30], Line[pos]},
{AbsoluteThickness[28], White, Line[pos]}};
disks = Table[{Darker[Yellow, 0.07], Disk[p, 0.25]},
{p, pos}];
numbers = MapIndexed[Style[Text[#, {#2[[1]], -#2[[2]]},
{-0.2, 0.2}], FontSize -> 12] &, mat, {2}];
Graphics[{outline, disks, numbers}, ImageSize -> 300]
Another possibility, using ItemStyle:
m = RandomInteger[10, {10, 10}];
c = {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {5, 5}, {5, 6}, {5, 7}, {4, 8}};
Grid[m, ItemStyle -> {Automatic, Automatic, Table[i -> {16, Red}, {i, c}]}]
Which ends up looking like this:
I may have misunderstood the question but this is what I thought you were asking for:
coords = Join ## Array[List, {3, 4}]
{{1, 1}, {1, 2}, {1, 3}, {1, 4}, {2, 1}, {2, 2}, {2, 3}, {2, 4}, {3,
1}, {3, 2}, {3, 3}, {3, 4}}
path = RandomSample[coords, Length[coords]]
{{1, 2}, {3, 3}, {2, 2}, {2, 4}, {3, 1}, {1, 4}, {1, 3}, {2, 1}, {3,
4}, {3, 2}, {2, 3}, {1, 1}}
labels = Text[StyleForm[#], #] & /# coords;
Graphics[Line[path], Epilog -> labels]

Drop nested Lists in Mathematica

Consider :
Tuples[Range[1, 3], 2]
I would like to drop some of the sublist based on the following list :
sublistToTemove = {1,2,3,6,8}
Desired Output :
{2, 1}, {2, 2}, {3, 1}
Corresponding to the 4th, 5th and 7th elements of list.
I have tried Drop, Case, Select without success, must be missing something.
Given your list:
In[2]:= lst = Tuples[Range[1, 3], 2]
Out[2]= {{1, 1}, {1, 2}, {1, 3}, {2, 1}, {2, 2}, {2, 3}, {3, 1}, {3,2}, {3, 3}}
and
In[5]:= sublistToTemove = {1, 2, 3, 6, 8}
Out[5]= {1, 2, 3, 6, 8}
Here are 2 ways:
In[6]:= Delete[lst, List /# sublistToTemove]
Out[6]= {{2, 1}, {2, 2}, {3, 1}, {3, 3}}
In[7]:= lst[[Complement[Range[Length[lst]], sublistToTemove]]]
Out[7]= {{2, 1}, {2, 2}, {3, 1}, {3, 3}}
In[15]:= sublistToTemove = {1, 2, 3, 6, 8};
In[16]:= Delete[Tuples[Range[1, 3], 2], Transpose[{sublistToTemove}]]
Out[16]= {{2, 1}, {2, 2}, {3, 1}, {3, 3}}

MapThread for any combination of variables

I have a set of regular (mod 5) matrices N2 and I would like to get the group generated by these matrices in Mathematica:
My approach was to use a function f doing the matrix multiplication and g for mod 5 and then I wanted to use MapThread
M= Function[{x,y},x.y];
g = Function[z, Mod[z, 5]]
g /# MapThread[M, {N2,N2}]
The problem is that MapThread is inserting only pairs of elements that are at the same position in the lists. I would like to insert any pair of elements in N. To get the group generated by the matrices in N I would just repeat this and update N2 every time.
E.g. let N2 ={A,B}
g /# MapThread[M, {N2,N2}]
would return {B^2,A^2}, while I want it to return any product of matrices in N2, i.e. {A^2,AB,BA,B^2}.
I'm not sure whether I understand your question, but if your intention is to get all combinations of the two matrices A,B you could use Tuples combined with Apply (which you may use in its functional form with square brackets or as many here do in initially cryptic prefix operator form ### = Apply at level 1):
In[24]:= Dot ### Tuples[{A, B}, 2]
Out[24]= {A.A, A.B, B.A, B.B}
In this case you need Outer:
In[27]:= n = RandomInteger[{1, 5}, {3, 2, 2}];
In[28]:= Outer[mFunc, n, n, 1]
Out[28]= {{mFunc[{{3, 5}, {2, 4}}, {{3, 5}, {2, 4}}],
mFunc[{{3, 5}, {2, 4}}, {{3, 4}, {4, 3}}],
mFunc[{{3, 5}, {2, 4}}, {{4, 4}, {5, 1}}]}, {mFunc[{{3, 4}, {4,
3}}, {{3, 5}, {2, 4}}],
mFunc[{{3, 4}, {4, 3}}, {{3, 4}, {4, 3}}],
mFunc[{{3, 4}, {4, 3}}, {{4, 4}, {5, 1}}]}, {mFunc[{{4, 4}, {5,
1}}, {{3, 5}, {2, 4}}],
mFunc[{{4, 4}, {5, 1}}, {{3, 4}, {4, 3}}],
mFunc[{{4, 4}, {5, 1}}, {{4, 4}, {5, 1}}]}}
In[29]:= n
Out[29]= {{{3, 5}, {2, 4}}, {{3, 4}, {4, 3}}, {{4, 4}, {5, 1}}}

Resources