Related
Imagine any game in which two six-sided dice are used.
It is needed to store the history of the game, we want to store the sums resulting from rolling the dice in the whole game.
In traditional Huffman enconding, 7 has bigger probability, so , it is encoded in 3 bits. 2 and 12 need 5 bits.
In this case, one symbol is encoded in variable code size.
However, I'm trying to figure out an enconding in which a single byte (8 bits) encode a different sequence of sum of dice.
So, in this case, the code size is constant (8 bits) , but the number of symbols is variable. Naive Example:
0x00 = {2}
0x01 = {3}
...
0x0A = {12}
0x0B = {2,2}
0x0C = {2,3}
0x0D = {2,4} etc.
So, the decoder can read byte by byte. Therefore each byte is independent of the other.
How to find the mapping that has the better compression?
Can you point to some algorithm that solves this case of compression?
My thoughts about this is:
Sequence of 1 sum can be assigned from 0x00 to 0x0A (from 2 to 12).
I can split the sequence {7} into: {7,1} , {7,2} ... {7,12} and assign values for these sequences.
If I do this for the whole list of {7,x}, then, I could remove {7} from the 1 sum values (because any sequence which starts by 7 is reachable by using the 2 sum sequences).
So, the resulting encoding would be:
{2} - {6}
{8} - {12}
{7,2} - {7,12}
Then, for example, I think: {6,6} , {6,7} or {6,8} could provide more "value" (bigger probability) than {7,2} or {7,12}.
But, if I remove {7,2} or {7,12}, then, I should return {7} to the list (otherwise, {7,2} could not be expressed).
Something like this:
{2} - {12}
{7,3} - {7,11}
{6,6} - {6,8}
So, there should be some kind of "trade-off" in this problem.
Here's a solution that I think achieves rate approximately 7.733629 bits per byte. (Generating code in Python 3, if you want to play with it: https://github.com/eisenstatdavid/huffman/blob/master/huffman.py) My algorithm is some EMish thing that alternately (1) computes the stationary distribution of the first roll in a byte (2) chooses the most 256 probable words subject to the constraint that we can encode any infinite sequence. I would conjecture optimality, though I know only that this solution is a local maximum (and even then, assuming my code has no bugs, etc.).
{{2}, {12}, {7, 7}, {6, 7}, {8, 7}, {5, 7}, {9, 7}, {4, 7}, {10,
7}, {7, 6}, {7, 8}, {6, 6}, {6, 8}, {8, 6}, {8, 8}, {5, 6}, {5, 8},
{9, 6}, {9, 8}, {4, 6}, {4, 8}, {10, 6}, {10, 8}, {7, 5}, {7, 9},
{6, 5}, {6, 9}, {8, 5}, {8, 9}, {5, 5}, {5, 9}, {9, 5}, {9, 9}, {3,
7}, {11, 7}, {4, 5}, {4, 9}, {10, 5}, {10, 9}, {7, 4}, {7, 10}, {3,
6}, {3, 8}, {11, 6}, {11, 8}, {6, 4}, {6, 10}, {8, 4}, {8, 10}, {5,
4}, {5, 10}, {9, 4}, {9, 10}, {4, 4}, {4, 10}, {10, 4}, {10, 10},
{3, 5}, {3, 9}, {11, 5}, {11, 9}, {7, 3}, {7, 11}, {2, 7}, {12, 7},
{6, 3}, {6, 11}, {8, 3}, {8, 11}, {5, 3}, {5, 11}, {9, 3}, {9, 11},
{3, 4}, {3, 10}, {11, 4}, {11, 10}, {4, 3}, {4, 11}, {10, 3}, {10,
11}, {2, 6}, {2, 8}, {12, 6}, {12, 8}, {2, 5}, {2, 9}, {12, 5},
{12, 9}, {3, 3}, {3, 11}, {11, 3}, {11, 11}, {7, 2}, {7, 12}, {7,
7, 7}, {2, 4}, {2, 10}, {12, 4}, {12, 10}, {6, 2}, {6, 12}, {8, 2},
{8, 12}, {6, 7, 7}, {8, 7, 7}, {5, 2}, {5, 12}, {9, 2}, {9, 12},
{5, 7, 7}, {9, 7, 7}, {4, 2}, {4, 12}, {10, 2}, {10, 12}, {4, 7,
7}, {10, 7, 7}, {7, 6, 7}, {7, 7, 6}, {7, 7, 8}, {7, 8, 7}, {6, 6,
7}, {6, 8, 7}, {8, 6, 7}, {8, 8, 7}, {6, 7, 6}, {6, 7, 8}, {8, 7,
6}, {8, 7, 8}, {5, 6, 7}, {5, 7, 6}, {5, 7, 8}, {5, 8, 7}, {9, 6,
7}, {9, 7, 6}, {9, 7, 8}, {9, 8, 7}, {4, 6, 7}, {4, 7, 6}, {4, 7,
8}, {4, 8, 7}, {10, 6, 7}, {10, 7, 6}, {10, 7, 8}, {10, 8, 7}, {7,
6, 6}, {7, 6, 8}, {7, 8, 6}, {7, 8, 8}, {7, 5, 7}, {7, 7, 5}, {7,
7, 9}, {7, 9, 7}, {6, 6, 6}, {6, 6, 8}, {6, 8, 6}, {6, 8, 8}, {8,
6, 6}, {8, 6, 8}, {8, 8, 6}, {8, 8, 8}, {5, 6, 6}, {5, 6, 8}, {5,
8, 6}, {5, 8, 8}, {9, 6, 6}, {9, 6, 8}, {9, 8, 6}, {9, 8, 8}, {2,
3}, {2, 11}, {12, 3}, {12, 11}, {6, 5, 7}, {6, 7, 5}, {6, 7, 9},
{6, 9, 7}, {8, 5, 7}, {8, 7, 5}, {8, 7, 9}, {8, 9, 7}, {5, 5, 7},
{5, 7, 5}, {5, 7, 9}, {5, 9, 7}, {9, 5, 7}, {9, 7, 5}, {9, 7, 9},
{9, 9, 7}, {4, 6, 6}, {4, 6, 8}, {4, 8, 6}, {4, 8, 8}, {10, 6, 6},
{10, 6, 8}, {10, 8, 6}, {10, 8, 8}, {3, 2}, {3, 12}, {11, 2}, {11,
12}, {3, 7, 7}, {11, 7, 7}, {4, 5, 7}, {4, 7, 5}, {4, 7, 9}, {4,
9, 7}, {10, 5, 7}, {10, 7, 5}, {10, 7, 9}, {10, 9, 7}, {7, 5, 6},
{7, 5, 8}, {7, 9, 6}, {7, 9, 8}, {7, 6, 5}, {7, 6, 9}, {7, 8, 5},
{7, 8, 9}, {6, 6, 5}, {6, 6, 9}, {6, 8, 5}, {6, 8, 9}, {8, 6, 5},
{8, 6, 9}, {8, 8, 5}, {8, 8, 9}, {6, 5, 6}, {6, 5, 8}, {6, 9, 6},
{6, 9, 8}, {8, 5, 6}, {8, 5, 8}, {8, 9, 6}, {8, 9, 8}, {5, 5, 6},
{5, 5, 8}, {5, 6, 5}, {5, 6, 9}, {5, 8, 5}, {5, 8, 9}, {5, 9, 6},
{5, 9, 8}, {9, 5, 6}, {9, 5, 8}, {9, 6, 5}, {9, 6, 9}, {9, 8, 5},
{9, 8, 9}, {9, 9, 6}, {9, 9, 8}, {7, 4, 7}, {7, 7, 4}, {7, 7, 10},
{7, 10, 7}}
There's a simpler, suboptimal solution that packs about 7.438148 bits of entropy into a byte. The 251 codewords are all length-3 sequences that start with {5, 7}, {6, 6}, {6, 7}, {6, 8}, {7, 5}, {7, 6}, {7, 7}, {7, 8}, {7, 9}, {8, 6}, {8, 7}, {8, 8}, {9, 7}, plus all length-2 sequences that don't start with one of those prefixes.
Chart of whether to take the third roll given the first two:
2 3 4 5 6 7 8 9 10 11 12
2 - - - - - - - - - - -
3 - - - - - - - - - - -
4 - - - - - - - - - - -
5 - - - - - X - - - - -
6 - - - - X X X - - - -
7 - - - X X X X X - - -
8 - - - - X X X - - - -
9 - - - - - X - - - - -
10 - - - - - - - - - - -
11 - - - - - - - - - - -
12 - - - - - - - - - - -
It's hard to analyze solutions where the encoder might or might not pack the next roll depending on what it is -- the probability distribution next time is affected.
Assuming you are interested in the sum, not in the sequence:
Variable length: Huffman
{2: 01110, 3: 0110, 4: 1100, 5: 000, 6: 001, 7: 010, 8: 100, 9: 101, 10: 111, 11: 1101, 12: 01111};
For fixed length: look for Tunstall coding
Imagine I have a 2D list of numbers in Mathematica :
myList = Table[{i,i*j},{i,1,10},{j,1,10}];
and I want to retrieve the 5th highest values in an efficient way. Using RankedMax gives an error. For example,
Max[myList]
gives 100 but:
RankedMax[myList,1]
gives :
RankedMax::vec : "Input {{{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, \
{1, 7}, {1, 8}, {1, 9}, {1, 10}}, {{2, 2}, {2, 4}, {2, 6}, {2, 8}, {2, 10}, \
{2, 12}, {2, 14}, {2, 16}, {2, 18}, {2, 20}}, 6, {{9, 9}, {9, 18}, {9, 27}, \
{9, 36}, {9, 45}, {9, 54}, {9, 63}, {9, 72}, {9, 81}, {9, 90}}, {{10, 10}, \
{10, 20}, {10, 30}, {10, 40}, {10, 50}, {10, 60}, {10, 70}, {10, 80}, {10, \
90}, {10, 100}}} is not a vector
How do I use RankedMax on my data or is there any other way around ?
Use Flatten
RankedMax[Flatten#myList,1]
This is fine if he's just looking for the fifth biggest of all the numbers in the table. If, as I suspect, he's looking for the fifth biggest of the calculated terms -- the second element in each pair -- we should slightly amend the previous solution to read:
RankedMax[Flatten#Map[Rest, myList, {2}], 5]
I have a following list:
lis={{1, {2}}, {3, {4, 5, 6}}, {7, {8, 9}}, {10, {11}}};
I'd like to obtain this:
lis2={{1, 2}, {3, 4}, {3, 5}, {3, 6}, {7, 8}, {7, 9}, {10, 11}};
I can achieve that using nested tables and calculating the length of the second nested list:
Flatten[Table[Table[{lis[[kk, 1]], lis[[kk, 2, ii]]}, {ii, 1, Length[lis[[kk, 2]]]}], {kk, 1, Length[lis]}], 1]
It works, but is there a more straightforward way? Perhaps a combination of Map/Thread/Apply?
One way:
ArrayFlatten[Distribute[#, List] & /# lis, 1]
=> {{1, 2}, {3, 4}, {3, 5}, {3, 6}, {7, 8}, {7, 9}, {10, 11}}
Edit
Or
ArrayFlatten[Thread /# lis, 1]
Edit 2
Or, slightly simpler, as Mr Wizard points out in a comment:
Flatten[Thread /# lis, 1]
Let’s assume we have a list of elements of the type {x,y,z} for x, y
and z integers. And, if needed x < y < z.
We also assume that the list contains at least 3 such triples.
Can Mathematica easily solve the following problem?
To detect at least one triple of the type {a,b,.}, {b,c,.} and {a,c,.}?
I am more intereseted in an elegant 1-liner than computational efficient solutions.
If I understood the problem, you want to detect triples not necessarily following one another, but generally present somewhere in the list. Here is one way to detect all such triples. First, some test list:
In[71]:= tst = RandomInteger[5,{10,3}]
Out[71]= {{1,1,0},{1,3,5},{3,3,4},{1,2,1},{2,0,3},{2,5,1},{4,2,2},
{4,3,4},{1,4,2},{4,4,3}}
Here is the code:
In[73]:=
Apply[Join,ReplaceList[tst,{___,#1,___,#2,___,#3,___}:>{fst,sec,th}]&###
Permutations[{fst:{a_,b_,_},sec:{b_,c_,_},th:{a_,c_,_}}]]
Out[73]= {{{1,4,2},{4,3,4},{1,3,5}},{{1,4,2},{4,2,2},{1,2,1}}}
This may perhaps satisfy your "one-liner" requirement, but is not very efficient. If you need only triples following one another, then, as an alternative to solution given by #Chris, you can do
ReplaceList[list,
{___, seq : PatternSequence[{a_, b_, _}, {b_, c_, _}, {a_,c_, _}], ___} :> {seq}]
I don't know if I interpreted your question correctly but suppose your list is something like
list = Sort /# RandomInteger[10, {20, 3}]
(*
{{3, 9, 9}, {0, 5, 6}, {3, 4, 8}, {4, 6, 10}, {3, 6, 9}, {1, 4, 8},
{0, 6, 10}, {2, 9, 10}, {3, 5, 9}, {6, 7, 9}, {0, 9, 10}, {1, 7, 10},
{4, 5, 10}, {0, 2, 5}, {0, 6, 7}, {1, 8, 10}, {1, 8, 10}}
*)
then you could do something like
ReplaceList[Sort[list],
{___, p:{a_, b_, _}, ___, q:{a_, c_, _}, ___, r:{b_, c_, _}, ___} :> {p, q, r}]
(* Output:
{{{0, 2, 5}, {0, 9, 10}, {2, 9, 10}}, {{3, 4, 8}, {3, 5, 9},
{4, 5, 10}}, {{3, 4, 8}, {3, 6, 9}, {4, 6, 10}}}
*)
Note that this works since it is given that for any element {x,y,z} in the original list we have x<=y. Therefore, for a triple {{a,b,_}, {a,c,_}, {b,c,_}} \[Subset] list we know that a<=b<=c. This means that the three elements {a,b,_}, {a,c,_}, and {b,c,_} will appear in that order in Sort[list].
To match triples "of the type {a,b,.}, {b,c,.} and {a,c,.}":
list = {{34, 37, 8}, {74, 32, 65}, {48, 77, 18}, {77, 100, 30},
{48, 100, 13}, {100, 94, 55}, {48, 94, 73}, {77, 28, 12},
{90, 91, 51}, {34, 5, 32}};
Cases[Partition[list, 3, 1], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}]
(Edited)
(Tuples was not the way to go)
Do you require something like:
list = RandomInteger[10, {50, 3}];
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}} /; a < b < c]
giving
{{{0, 1, 2}, {1, 5, 2}, {0, 5, 4}},
{{2, 3, 5},{3, 4, 10}, {2, 4, 5}},
{{6, 8, 10}, {8, 10, 10},{6, 10, 0}},
{{2, 4, 5}, {4, 8, 2}, {2, 8, 5}},
{{2, 4, 5}, {4, 7, 7}, {2, 7, 3}},
{{0, 2, 2}, {2, 7, 3}, {0, 7, 2}},
{{0, 2, 1}, {2, 7, 3}, {0, 7, 2}}}
or perhaps (as other have interpreted the question):
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}];
Suppose I have n=6 distinct monomers each of which has two distinct and reactive ends. During each round of reaction, one random end unites with another random end, either elongates the monomer to a dimer or self-associates into a loop. This reaction process stops whenever no free ends are present in the system. I want to use Mma to simulate the reaction process.
I am thinking to represent the monomers as a list of strings, {'1-2', '3-4', '5-6', '7-8', '9-10', '11-12'}, then to do one round of reacion by updating the content of the list, for example either {'1-2-1', '3-4', '5-6', '7-8', '9-10', '11-12'} or {'1-2-3-4', '5-6', '7-8', '9-10', '11-12'}. But I am not able to go very far due to my programming limitation in Mma. Could anyone please help? Thanks a lot.
Here is the set-up:
Clear[freeVertices];
freeVertices[edgeList_List] := Select[Tally[Flatten[edgeList]], #[[2]] < 2 &][[All, 1]];
ClearAll[setNew, componentsBFLS];
setNew[x_, x_] := Null;
setNew[lhs_, rhs_] := lhs := Function[Null, (#1 := #0[##]); #2, HoldFirst][lhs, rhs];
componentsBFLS[lst_List] :=
Module[{f}, setNew ### Map[f, lst, {2}]; GatherBy[Tally[Flatten#lst][[All, 1]], f]];
Here is the start:
In[13]:= start = Partition[Range[12], 2]
Out[13]= {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}
Here are the steps:
In[51]:= steps =
NestWhileList[Append[#, RandomSample[freeVertices[#], 2]] &,
start, freeVertices[#] =!= {} &]
Out[51]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1,
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}}, {{1,
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3,
4}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5,
1}, {3, 4}, {7, 11}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9,
10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}}, {{1, 2}, {3,
4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8,
2}, {6, 10}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11,
12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}, {6, 10}, {9, 12}}}
Here are the connected components (cycles etc), which you can study:
In[52]:= componentsBFLS /# steps
Out[52]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2,
5, 6}, {3, 4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3,
4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3, 4}, {7, 8, 11,
12}, {9, 10}}, {{1, 2, 5, 6, 7, 8, 11, 12}, {3, 4}, {9, 10}}, {{1,
2, 5, 6, 7, 8, 9, 10, 11, 12}, {3, 4}}, {{1, 2, 5, 6, 7, 8, 9, 10,
11, 12}, {3, 4}}}
What happens is that we treat all pairs as edges in one big graph, and add an edge randomly if both vertices have at most one connection to some other edge at the moment. At some point, the process stops. Then, we map the componentsBFLS function onto resulting graphs (representing the steps of the simulation), to get the connected components of the graphs (steps). You could use other metrics as well, of course, and write more functions which will analyze the steps for loops etc. Hope this will get you started.
It seems like it would be more natural to represent your molecules as lists rather than strings. So start with {{1,2},{3,4},{5,6}} and so on. Then open chains are just longer lists {1,2,3,4} or whatever, and have some special convention for loops such as starting with the symbol "loop". {{loop,1,2},{3,4,5,6},{7,8}} or whatever.
How detailed does your simulation actually need to be? For instance, do you actually care which monomers end up next to which, or do you only care about the statistics of the lengths of chains? In the latter case, you could greatly simplify the state of your simulation: it could, for instance, consist of a list of loop lengths (which would start empty) and a list of open chain lengths (which would start as a bunch of 1s). Then one simulation step is: pick an open chain at random; with appropriate probabilities, either turn that into a loop or combine it with another open chain.
Mathematica things you might want to look up: RandomInteger, RandomChoice; Prepend, Append, Insert, Delete, ReplacePart, Join; While (though actually some sort of "functional iteration" with, e.g., NestWhile might make for prettier code).
Here's a simple approach. Following the examples given in the question, I've assumed that the monomers have a prefered binding, so that only {1,2} + {3,4} -> {1,2,3,4} OR {1,2,1} + {3,4,3} is possible, but {1,2} + {3,4} -> {1,2,4,3} is not possible. The following code should be packaged up as a nice function/module once you are happy with it. If you're after statistics, then it can also probably be compiled to add some speed.
Initialize:
In[1]:= monomers=Partition[Range[12],2]
loops={}
Out[1]= {{1,2},{3,4},{5,6},{7,8},{9,10},{11,12}}
Out[2]= {}
The loop:
In[3]:= While[monomers!={},
choice=RandomInteger[{1,Length[monomers]},2];
If[Equal##choice,
AppendTo[loops, monomers[[choice[[1]]]]];
monomers=Delete[monomers,choice[[1]]],
monomers=Prepend[Delete[monomers,Transpose[{choice}]],
Join##Extract[monomers,Transpose[{choice}]]]];
Print[monomers,"\t",loops]
]
During evaluation of In[3]:= {{7,8,1,2},{3,4},{5,6},{9,10},{11,12}} {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10},{11,12}} {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10}} {{11,12}}
During evaluation of In[3]:= {{3,4,5,6,7,8,1,2},{9,10}} {{11,12}}
During evaluation of In[3]:= {{9,10}} {{11,12},{3,4,5,6,7,8,1,2}}
During evaluation of In[3]:= {} {{11,12},{3,4,5,6,7,8,1,2},{9,10}}
Edit:
If the monomers can bind at both ends, you just add a option to flip on of the monomers that you join, e.g.
Do[
choice=RandomInteger[{1,Length[monomers]},2];
reverse=RandomChoice[{Reverse,Identity}];
If[Equal##choice,
AppendTo[loops,monomers[[choice[[1]]]]];
monomers=Delete[monomers,choice[[1]]],
monomers=Prepend[Delete[monomers,Transpose[{choice}]],
Join[monomers[[choice[[1]]]],reverse#monomers[[choice[[2]]]]]]];
Print[monomers,"\t",loops],{Length[monomers]}]
{{7,8,10,9},{1,2},{3,4},{5,6},{11,12}} {}
{{3,4,5,6},{7,8,10,9},{1,2},{11,12}} {}
{{3,4,5,6},{7,8,10,9},{11,12}} {{1,2}}
{{7,8,10,9},{11,12}} {{1,2},{3,4,5,6}}
{{7,8,10,9,11,12}} {{1,2},{3,4,5,6}}
{} {{1,2},{3,4,5,6},{7,8,10,9,11,12}}
I see my implementation mimics Simon's closely. Reminder to self: never go to bed before posting solution...
simulatePolimerization[originalStuff_] :=
Module[{openStuff = originalStuff, closedStuff = {}, picks},
While[Length[openStuff] > 0,
picks = RandomInteger[{1, Length[openStuff]}, 2];
openStuff = If[RandomInteger[1] == 1, Reverse[#], #] & /# openStuff;
If[Equal ## picks,
(* closing *)
AppendTo[closedStuff,Append[openStuff[[picks[[1]]]], openStuff[[picks[[1]], 1]]]];
openStuff = Delete[openStuff, picks[[1]]],
(* merging *)
AppendTo[openStuff,Join[openStuff[[picks[[1]]]], openStuff[[picks[[2]]]]]];
openStuff = Delete[openStuff, List /# picks]
]
];
Return[closedStuff]
]
Some results: