Related
let n be an integer and A = {2,3,...,10} and I want to do as follows:
divide n to 2, so there is a reminder r2 and a quotient q2.
divide q2 to 3, so there is a reminder r3 and a quotient q3.
we repeat this until the quotient is less than the next number.
write together the last quotient with the previous reminders.
For example n=45
45/2 ....... r_2=1, q_2=22
22/3 ....... r_3=1, q_3=7
7/4 ....... r_4=3, q_4=1
since q4 = 1 is less than the next number i.e. 5, we break.
the result is q4r4r3r2 where it is equal to 1311.
Thank you for your help.
I did this but it does not work
n = 45;
i = 2;
list = {Mod[n, i]};
While[Quotient[n, i] >= i + 1, n == Quotient[n, i]; i++;
AppendTo[list, Mod[n, i]];
If[Quotient[n, i] < i + 1, Break[]]; AppendTo[list, Quotient[n, i]]];
list
Row[Reverse[list]]
which gives
{1, 0, 15, 1, 11, 0, 9, 3, 7, 3}
Row[{3, 7, 3, 9, 0, 11, 1, 15, 0, 1}]
where it is not my desired result.
This is the code:
A = Table[i, {i, 2, 10}]; (* array of numbers *)
n = 45; (* initial value *)
ans = {}; (* future answer which is now empty list *)
For[i = 1, i <= Length[A], i++, (* looping over A *)
If[n < A[[i]], (* exit condition *)
ans = Append[ans, n]; (* appending last n when exit *)
Break[]
];
qr = QuotientRemainder[n, A[[i]]]; (* calculating both quotient and reminder *)
ans = Append[ans, qr[[2]]]; (* adding second member to the answer *)
Print[qr]; (* printing *)
n = qr[[1]]; (* using first member as new n to process *)
];
ans (* printing result in Mathematica manner *)
It gives
{1, 1, 3, 1}
You might use something like this:
f[n_Integer] :=
NestWhileList[
{QuotientRemainder[#[[1, 1]], #[[2]] + 1], #[[2]] + 1} &,
{{n}, 1},
#[[1, 1]] != 0 &
] // Rest
f[45]
{{{22, 1}, 2}, {{7, 1}, 3}, {{1, 3}, 4}, {{0, 1}, 5}}
You can use Part to get whatever bits of the output you desire.
Here's a somewhat more advanced way if you can handle the syntax:
f2[n_Integer] := Reap[f2[{n, 0}, 2]][[2, 1, 2 ;;]] // Reverse
f2[{q_, r_}, i_] := f2[Sow # r; QuotientRemainder[q, i], i + 1]
f2[{0, r_}, i_] := Sow # r
f2[45]
{1, 3, 1, 1}
This is a fun little problem, and I wanted to check with the experts here if there is a better functional/Mathematica way to approach solving it than what I did. I am not too happy with my solution since I use big IF THEN ELSE in it, but could not find a Mathematica command to use easily to do it (such as Select, Cases, Sow/Reap, Map.. etc...)
Here is the problem, given a list values (numbers or symbols), but for simplicity, lets assume a list of numbers for now. The list can contain zeros and the goal is replace the each zero with the element seen before it.
At the end, the list should contain no zeros in it.
Here is an example, given
a = {1, 0, 0, -1, 0, 0, 5, 0};
the result should be
a = {1, 1, 1, -1, -1, -1, 5, 5}
It should ofcourse be done in the most efficient way.
This is what I could come up with
Scan[(a[[#]] = If[a[[#]] == 0, a[[#-1]], a[[#]]]) &, Range[2, Length[a]]];
I wanted to see if I can use Sow/Reap on this, but did not know how.
question: can this be solved in a more functional/Mathematica way? The shorter the better ofcourse :)
update 1
Thanks everyone for the answer, all are very good to learn from. This is the result of speed test, on V 8.04, using windows 7, 4 GB Ram, intel 930 #2.8 Ghz:
I've tested the methods given for n from 100,000 to 4 million. The ReplaceRepeated method does not do well for large lists.
update 2
Removed earlier result that was shown above in update1 due to my error in copying one of the tests.
The updated results are below. Leonid method is the fastest. Congratulation Leonid. A very fast method.
The test program is the following:
(*version 2.0 *)
runTests[sizeOfList_?(IntegerQ[#] && Positive[#] &)] :=
Module[{tests, lst, result, nasser, daniel, heike, leonid, andrei,
sjoerd, i, names},
nasser[lst_List] := Module[{a = lst},
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]]
];
daniel[lst_List] := Module[{replaceWithPrior},
replaceWithPrior[ll_, n_: 0] :=
Module[{prev}, Map[If[# == 0, prev, prev = #] &, ll]
];
replaceWithPrior[lst]
];
heike[lst_List] := Flatten[Accumulate /# Split[lst, (#2 == 0) &]];
andrei[lst_List] := Module[{x, y, z},
ReplaceRepeated[lst, {x___, y_, 0, z___} :> {x, y, y, z},
MaxIterations -> Infinity]
];
leonid[lst_List] :=
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] & #lst;
sjoerd[lst_List] :=
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, lst];
lst = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]],
sizeOfList];
tests = {nasser, daniel, heike, leonid, sjoerd};
names = {"Nasser","Daniel", "Heike", "Leonid", "Sjoerd"};
result = Table[0, {Length[tests]}, {2}];
Do[
result[[i, 1]] = names[[i]];
Block[{j, r = Table[0, {5}]},
Do[
r[[j]] = First#Timing[tests[[i]][lst]], {j, 1, 5}
];
result[[i, 2]] = Mean[r]
],
{i, 1, Length[tests]}
];
result
]
To run the tests for length 1000 the command is:
Grid[runTests[1000], Frame -> All]
Thanks everyone for the answers.
Much (order of magnitude) faster than other solutions still:
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] &
The speedup is due to Fold autocompiling. Will not be so dramatic for non-packed arrays. Benchmarks:
In[594]:=
a=b=c=RandomChoice[Join[ConstantArray[0,10],Range[-1,5]],150000];
(b=Flatten[Accumulate/#Split[b,(#2==0)&]]);//Timing
Scan[(a[[#]]=If[a[[#]]==0,a[[#-1]],a[[#]]])&,Range[2,Length[a]]]//Timing
(c=FoldList[If[#2==0,#1,#2]&,First##,Rest##]&#c);//Timing
SameQ[a,b,c]
Out[595]= {0.187,Null}
Out[596]= {0.625,Null}
Out[597]= {0.016,Null}
Out[598]= True
This seems to be a factor 4 faster on my machine:
a = Flatten[Accumulate /# Split[a, (#2 == 0) &]]
The timings I get are
a = b = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]], 10000];
(b = Flatten[Accumulate /# Split[b, (#2 == 0) &]]); // Timing
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]] // Timing
SameQ[a, b]
(* {0.015815, Null} *)
(* {0.061929, Null} *)
(* True *)
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, d]
is about 10 and 2 times faster than Heike's solutions but slower than Leonid's.
You question looks exactly like a task for ReplaceRepeated function. What it does basically is that it applies the same set of rules to the expression until no more rules are applicable. In your case the expression is a list, and the rule is to replace 0 with its predecessor whenever occurs in a list. So here is the solution:
a = {1, 0, 0, -1, 0, 0, 5, 0};
a //. {x___, y_, 0, z___} -> {x, y, y, z};
The pattern for the rule here is the following:
x___ - any symbol, zero or more repetitions, the beginning of the list
y_ - exactly one element before zero
0 - zero itself, this element will be replaced with y later
z___ - any symbol, zero or more repetitions, the end of the list
While looking at the belisarius's question about generation of non-singular integer matrices with uniform distribution of its elements, I was studying a paper by Dana Randal, "Efficient generation of random non-singular matrices". The algorithm proposed is recursive, and involves generating a matrix of lower dimension and assigning it to a given minor. I used combinations of Insert and Transpose to do it, but there are must be more efficient ways of doing it. How would you do it?
The following is the code:
Clear[Gen];
Gen[p_, 1] := {{{1}}, RandomInteger[{1, p - 1}, {1, 1}]};
Gen[p_, n_] := Module[{v, r, aa, tt, afr, am, tm},
While[True,
v = RandomInteger[{0, p - 1}, n];
r = LengthWhile[v, # == 0 &] + 1;
If[r <= n, Break[]]
];
afr = UnitVector[n, r];
{am, tm} = Gen[p, n - 1];
{Insert[
Transpose[
Insert[Transpose[am], RandomInteger[{0, p - 1}, n - 1], r]], afr,
1], Insert[
Transpose[Insert[Transpose[tm], ConstantArray[0, n - 1], r]], v,
r]}
]
NonSingularRandomMatrix[p_?PrimeQ, n_] := Mod[Dot ## Gen[p, n], p]
It does generate a non-singular matrix, and has uniform distribution of matrix elements, but requires p to be prime:
The code is also not every efficient, which is, I suspect due to my inefficient matrix constructors:
In[10]:= Timing[NonSingularRandomMatrix[101, 300];]
Out[10]= {0.421, Null}
EDIT So let me condense my question. The minor matrix of a given matrix m can be computed as follows:
MinorMatrix[m_?MatrixQ, {i_, j_}] :=
Drop[Transpose[Drop[Transpose[m], {j}]], {i}]
It is the original matrix with i-th row and j-th column deleted.
I now need to create a matrix of size n by n that will have the given minor matrix mm at position {i,j}. What I used in the algorithm was:
ExpandMinor[minmat_, {i_, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[minmat] :=
Insert[Transpose[Insert[Transpose[minmat], v2, j]], v1, i]
Example:
In[31]:= ExpandMinor[
IdentityMatrix[4], {2, 3}, {1, 2, 3, 4, 5}, {2, 3, 4, 4}]
Out[31]= {{1, 0, 2, 0, 0}, {1, 2, 3, 4, 5}, {0, 1, 3, 0, 0}, {0, 0, 4,
1, 0}, {0, 0, 4, 0, 1}}
I am hoping this can be done more efficiently, which is what I am soliciting in the question.
Per blisarius's suggestion I looked into implementing ExpandMinor via ArrayFlatten.
Clear[ExpandMinorAlt];
ExpandMinorAlt[m_, {i_ /; i > 1, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
ArrayFlatten[{
{Part[m, ;; i - 1, ;; j - 1], Transpose#{v2[[;; i - 1]]},
Part[m, ;; i - 1, j ;;]},
{{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
{Part[m, i ;;, ;; j - 1], Transpose#{v2[[i ;;]]}, Part[m, i ;;, j ;;]}
}]
ExpandMinorAlt[m_, {1, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
ArrayFlatten[{
{{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
{Part[m, All, ;; j - 1], Transpose#{v2}, Part[m, All, j ;;]}
}]
In[192]:= dim = 5;
mm = RandomInteger[{-5, 5}, {dim, dim}];
v1 = RandomInteger[{-5, 5}, dim + 1];
v2 = RandomInteger[{-5, 5}, dim];
In[196]:=
Table[ExpandMinor[mm, {i, j}, v1, v2] ==
ExpandMinorAlt[mm, {i, j}, v1, v2], {i, dim}, {j, dim}] //
Flatten // DeleteDuplicates
Out[196]= {True}
It took me a while to get here, but since I spent a good part of my postdoc generating random matrices, I could not help it, so here goes. The main inefficiency in the code comes from the necessity to move matrices around (copy them). If we could reformulate the algorithm so that we only modify a single matrix in place, we could win big. For this, we must compute the positions where the inserted vectors/rows will end up, given that we will typically insert in the middle of smaller matrices and thus shift the elements. This is possible. Here is the code:
gen = Compile[{{p, _Integer}, {n, _Integer}},
Module[{vmat = Table[0, {n}, {n}],
rs = Table[0, {n}],(* A vector of r-s*)
amatr = Table[0, {n}, {n}],
tmatr = Table[0, {n}, {n}],
i = 1,
v = Table[0, {n}],
r = n + 1,
rsc = Table[0, {n}], (* recomputed r-s *)
matstarts = Table[0, {n}], (* Horizontal positions of submatrix starts at a given step *)
remainingShifts = Table[0, {n}]
(*
** shifts that will be performed after a given row/vector insertion,
** and can affect the real positions where the elements will end up
*)
},
(*
** Compute the r-s and vectors v all at once. Pad smaller
** vectors v with zeros to fill a rectangular matrix
*)
For[i = 1, i <= n, i++,
While[True,
v = RandomInteger[{0, p - 1}, i];
For[r = 1, r <= i && v[[r]] == 0, r++];
If[r <= i,
vmat[[i]] = PadRight[v, n];
rs[[i]] = r;
Break[]]
]];
(*
** We must recompute the actual r-s, since the elements will
** move due to subsequent column insertions.
** The code below repeatedly adds shifts to the
** r-s on the left, resulting from insertions on the right.
** For example, if vector of r-s
** is {1,2,1,3}, it will become {1,2,1,3}->{2,3,1,3}->{2,4,1,3},
** and the end result shows where
** in the actual matrix the columns (and also rows for the case of
** tmatr) will be inserted
*)
rsc = rs;
For[i = 2, i <= n, i++,
remainingShifts = Take[rsc, i - 1];
For[r = 1, r <= i - 1, r++,
If[remainingShifts[[r]] == rsc[[i]],
Break[]
]
];
If[ r <= n,
rsc[[;; i - 1]] += UnitStep[rsc[[;; i - 1]] - rsc[[i]]]
]
];
(*
** Compute the starting left positions of sub-
** matrices at each step (1x1,2x2,etc)
*)
matstarts = FoldList[Min, First#rsc, Rest#rsc];
(* Initialize matrices - this replaces the recursion base *)
amatr[[n, rsc[[1]]]] = 1;
tmatr[[rsc[[1]], rsc[[1]]]] = RandomInteger[{1, p - 1}];
(* Repeatedly perform insertions - this replaces recursion *)
For[i = 2, i <= n, i++,
amatr[[n - i + 2 ;; n, rsc[[i]]]] = RandomInteger[{0, p - 1}, i - 1];
amatr[[n - i + 1, rsc[[i]]]] = 1;
tmatr[[n - i + 2 ;; n, rsc[[i]]]] = Table[0, {i - 1}];
tmatr[[rsc[[i]],
Fold[# + 1 - Unitize[# - #2] &,
matstarts[[i]] + Range[0, i - 1], Sort[Drop[rsc, i]]]]] =
vmat[[i, 1 ;; i]];
];
{amatr, tmatr}
],
{{FoldList[__], _Integer, 1}}, CompilationTarget -> "C"];
NonSignularRanomMatrix[p_?PrimeQ, n_] := Mod[Dot ## Gen[p, n],p];
NonSignularRanomMatrixAlt[p_?PrimeQ, n_] := Mod[Dot ## gen[p, n],p];
Here is the timing for the large matrix:
In[1114]:= gen [101, 300]; // Timing
Out[1114]= {0.078, Null}
For the histogram, I get the identical plots, and the 10-fold efficiency boost:
In[1118]:=
Histogram[Table[NonSignularRanomMatrix[11, 5][[2, 3]], {10^4}]]; // Timing
Out[1118]= {7.75, Null}
In[1119]:=
Histogram[Table[NonSignularRanomMatrixAlt[11, 5][[2, 3]], {10^4}]]; // Timing
Out[1119]= {0.687, Null}
I expect that upon careful profiling of the above compiled code, one could further improve the performance. Also, I did not use runtime Listable attribute in Compile, while this should be possible. It may also be that the parts of the code which perform assignment to minors are generic enough so that the logic can be factored out of the main function - I did not investigate that yet.
For the first part of your question (which I hope I understand properly) can
MinorMatrix be written as follows?
MinorMatrixAlt[m_?MatrixQ, {i_, j_}] := Drop[mat, {i}, {j}]
To get acquainted with Mathematica's solving functions, I tried to work out a solution to a MinuteMath problem:
There is a list of seven numbers. The average of the first four numbers is 5, and the
average of the last four numbers is 8. If the average of all seven numbers is 46/7, then
what is the number common to both sets of four numbers?
Of course, this is an excercise that can be solved without computer, but how can I solve this using Mathematica? My first approach
X = Table[Subscript[x, i], {i, 1, 7}];
cond = {
Mean[Part[X, 1 ;; 4]] == 5,
Mean[Part[X, 4 ;; 7]] == 8,
Mean[X] == 46/7
};
Solve[cond, Subscript[x, 4]]
returned no solution. My second approach
X = Table[Subscript[x, i], {i, 1, 7}];
rules = {Mean[Part[X, 1 ;; 4]] -> 5,
Mean[Part[X, 4 ;; 7]] -> 8,
Mean[X] -> 46/7
};
Solve[
Mean[X] == Mean[Part[X, 1 ;; 4]]
+ Mean[Part[X, 4 ;; 7]]
- Subscript[x, 4] /. rules,
Subscript[x, 4]
]
gives a wrong solution (45/7 instead 6). What did I wrong?
The first piece of code that you give is fine. The only problem is there is no solution for x_4 alone. If you replace the last line by Solve[cond] then Mathmatica automagically chooses the free variables and you'll get the solution.
I think that a simple/trivial example would make this type problem clear:
In[1]:= Solve[x==1&&y==2,x]
Solve[x==1&&y==2,{x,y}]
Out[1]= {}
Out[2]= {{x->1,y->2}}
The final output can also be obtained using Solve[x==1&&y==2], where Mma guesses the free variables. This behaviour differs from that of Mathematica 7. In Mathematica 8 a new option for Solve (and related functions) called MaxExtraCondtions was introduced. This allows Solve to give solutions that use the new ConditionalExpression and is intended to make the behaviour of solve more consistent and predictable.
Here's how it works in this simple example:
In[3]:= Solve[x==1&&y==2, x, MaxExtraConditions->1]
Out[3]= {{x -> ConditionalExpression[1, y==2]}}
See the above linked to docs for more examples that show why this Option is useful. (Although maybe defaulting to Automatic instead of 0 would be a more pragmatic design choice for the new option...)
Finally, here's your first solution rewritten a little:
In[1]:= X=Array[Symbol["x"<>ToString[#]]&,{7}]
Out[1]= {x1,x2,x3,x4,x5,x6,x7}
In[2]:= cond=Mean[X[[1;;4]]]==5&&Mean[X[[4;;7]]]==8&&Mean[X]==46/7;
In[3]:= Solve[cond]
x4/.%
Out[3]= {{x1->14-x2-x3,x4->6,x5->26-x6-x7}}
Out[4]= {6}
Perhaps more compact:
Reduce[Mean#Array[f, 4] == 5 &&
Mean#Array[f, 4, 4] == 8 &&
Mean#Array[f, 7] == 46/7]
(*
-> f[5] == 26 - f[6] - f[7] &&
f[4] == 6 &&
f[1] == 14 - f[2] - f[3]
*)
Although for clarity, I probably prefer:
Reduce[Sum[f#i, {i, 4}] == 20 &&
Sum[f#i, {i, 4, 7}] == 32 &&
Sum[f#i, {i, 7}] == 46]
Edit
Note that I am using function upvalues as vars and not list elements. I prefer this way because:
You don't need to initialize the list
(Table[Subscript ... in your
example`)
The resulting expressions are usually
less cluttered (No Part[ ;; ], etc)
I'd like a function AnyTrue[expr,{i,{i1,i2,...}}] which checks if expr is True for any of i1,i2... It should be as if AnyTrue was Table followed by Or##%, with the difference that it only evaluates expr until first True is found.
Short-circuiting part is optional, what I'd really like to know is the proper way to emulate Table's non-standard evaluation sequence.
Update 11/14
Here's a solution due to Michael, you can use it to chain "for all" and "there exists" checks
SetAttributes[AllTrue, HoldAll];
SetAttributes[AnyTrue, HoldAll];
AllTrue[{var_Symbol, lis_List}, expr_] :=
LengthWhile[lis,
TrueQ[ReleaseHold[Hold[expr] /. HoldPattern[var] -> #]] &] ==
Length[lis];
AnyTrue[{var_Symbol, lis_List}, expr_] :=
LengthWhile[lis,
Not[TrueQ[ReleaseHold[Hold[expr] /. HoldPattern[var] -> #]]] &] <
Length[lis];
AllTrue[{a, {1, 3, 5}}, AnyTrue[{b, {2, 4, 5}}, EvenQ[a + b]]]
AnyTrue[{a, {1, 3, 5}}, AllTrue[{b, {2, 4, 5}}, EvenQ[a + b]]]
How about this?
SetAttributes[AnyTrue, HoldAll];
AnyTrue[expr_, {var_Symbol, lis_List}] :=
LengthWhile[lis,
Not[TrueQ[ReleaseHold[Hold[expr] /. HoldPattern[var] -> #]]] &
] < Length[lis]
Includes short-circuiting via LengthWhile and keeps everything held where necessary so that things work as expected with var has a value outside the function:
In[161]:= x = 777;
In[162]:= AnyTrue[Print["x=", x]; x == 3, {x, {1, 2, 3, 4, 5}}]
During evaluation of In[162]:= x=1
During evaluation of In[162]:= x=2
During evaluation of In[162]:= x=3
Out[162]= True
The built-in Or is short-circuiting, too, for what it's worth. (but I realize building up the unevaluated terms with e.g. Table is a pain):
In[173]:= Or[Print[1];True, Print[2];False]
During evaluation of In[173]:= 1
Out[173]= True
This doesn't match your spec but I often use the following utility functions, which are similar to what you have in mind (they use pure functions instead of expressions with a specified variable) and also do short-circuiting:
some[f_, l_List] := True === (* Whether f applied to some *)
Scan[If[f[#], Return[True]]&, l]; (* element of list is True. *)
every[f_, l_List] := Null === (* Similarly, And ## f/#l *)
Scan[If[!f[#], Return[False]]&, l]; (* (but with lazy evaluation). *)
For example, Michael Pilat's example would become this:
In[1]:= some[(Print["x=", #]; # == 3)&, {1, 2, 3, 4, 5}]
During evaluation of In[1]:= x=1
During evaluation of In[1]:= x=2
During evaluation of In[1]:= x=3
Out[1]= True