Laplacian or Grad of an InterpolatingFunction

For obtaining a **Schlieren image** from an equation for density, I need to calculate the first derivative of density and make a contour plot. The below code snippet calculates the first derivative w.r.t `x` and `y` and makes a contour plot. All is well until this step. `hSol` is an interpolating function polynomial, `TRup` is the final time of calculation/rupture time in `NDSolve` and `fac` is just a value between 0 and 1.               T = 1 - hSol[x, y, fac*TRup]/(hSol[x, y, fac*TRup] + 1);      a = 9.2/10^4;      b = 4.5/10^7;      r = 0.97/(1 + a*T + b*T^2);      ContourPlot[Evaluate[D[r, x] + D[r, y], {x, 0, L}, {y, 0, L}],         PlotRange -> {{0, L}, {0, L}, {0, 3.5}},         BaseStyle -> {FontWeight -> "Bold", FontSize -> 18},       Contours -> 75]      If I replace the `dx dy` terms with `Grad[r]` or `Laplacian[r]`, it errors out:   1. Either it locks up the RAM and my computer crashes.   2. Or All the code in my notebook turns to BLUE as if it were never evaluated in the first place. What's that all about? I tried it with a simpler problem as in Example 1 and i could replace `y'` in the `ParametricPlot` of `In[3]` with `Laplacian[]` and things worked well. (I do realize that `y'` is not `Laplacian`...) * _(MY CODE)_ *Mathematica code that produces the interpolating function polynomial: * * *               (*"Specifies the number of previous lines of input and output to keep in a Mathematica session."*)     $HistoryLength=0;     (*Loads necessary packages to perform vector analysis*)     Needs["VectorAnalysis`"]     Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];     (*Clears equation symbols*)     Clear[Eq0,EvapThickFilm,h,Bo,\[Epsilon],K1,\[Delta],Bi,m,r] (*Eq0 and EvapThickFilm are variable names. These can be changed as long as the change is made through the entire document*)     (*'h' is the film thickness variable, 'Bo' is the Bond number (G/S), '\[Epsilon]' is the epsilon from the maximizing wavelength equation, 'K1' is the non-equilibrium coefficient, '\[Delta]' is the delta term from the max wavelength equation, 'Bi' is the Biot number, 'm' is the m term and 'r' is the modified Rayleigh number term*)     Eq0[h_,{Bo_,\[Epsilon]_,K1_,\[Delta]_,Bi_,m_,r_}]:=\!\(     \*SubscriptBox[\(\[PartialD]\), \(t\)]h\)+Div[-h^3 Bo Grad[h]+h^3 Grad[Laplacian[h]]+(\[Delta] h^3)/(Bi h+K1)^3 Grad[h]+m (h/(K1+Bi h))^2 Grad[h]]+\[Epsilon]/(Bi h+K1) + (r)D[D[(h^2/(K1+Bi h)),x] h^3,x] ==0; (*This is the evolution equation in 3D cartesian coordinates*)     SetCoordinates[Cartesian[x,y,z]];     EvapThickFilm[Bo_,\[Epsilon]_,K1_,\[Delta]_,Bi_,m_,r_]:=Eq0[h[x,y,t],{Bo,\[Epsilon],K1,\[Delta],Bi,m,r}];     TraditionalForm[EvapThickFilm[Bo,\[Epsilon],K1,\[Delta],Bi,m,r]];                              (*Domain size in non dimensional units*)L=76.1311;  (*Maximum time of iteration*)TMax=5000*100;     Off[NDSolve::mxsst];     Clear[Kvar];     (*Kvar[t_]:=  Piecewise[{{1,t<=1},{2,t>1}}]*)     (*Ktemp = Array[0.001+0.001#^2&,13]*)     hSol=h/.NDSolve[{     (*Bo,\[Epsilon],K1,\[Delta],Bi,m,r*)     (*Non dimensional number values are fed into the evolution equation which is called here with 'EvapThickFilm[...]'. The arguments, in order are, Bo, \[Epsilon], K1, \[Delta], m, r. These are the exact values used in Oron et al.*)     EvapThickFilm[0.0,0,1,0,1,0.0544911,0],          (*Periodic boundary conditions at the left and right walls in x and y directions*)     h[0,y,t]==h[L,y,t],     h[x,0,t]==h[x,L,t],     (*h[x,y,0] == 1.1+Cos[x] Sin[2y] *)     (*Initial condition as used in Oron et al.*)     h[x,y,0]==1+(-0.05 Cos[2\[Pi] x/L] -0.05 Sin[2\[Pi] x/L])Cos[2 \[Pi] y/L]     },     h,     {x, 0, L},     {y,0, L},     {t, 0, TMax},     Method->{"BDF","MaxDifferenceOrder"->1},     MaxStepFraction->1/50     ][[1]]                    fac = 0.99;     hGrid = InterpolatingFunctionGrid[hSol];     {TMin, TRup} = InterpolatingFunctionDomain[hSol][[3]]     Length[hGrid]     {nX, nY, nT} = Drop[Dimensions[hGrid], -1]


MapThread with several cells as output

Assume I have defined the following function:               FF[{x_, y_}] := {x^2 + y^3, 3.5*x*y}      I would like to apply `FF` on a list of input such as:               XX = {xa, xb, xc}     YY = {ya, yb, yc}      In order to do it I input the following syntax:               MapThread[FF, {XX, YY}]      but as output I get just the first element of the function:               {xa^2+ya^3, xb^2+yb^3, xc^2+yc^3}      what am I doing wrong here?


How to demodulate an FM signal in continuous-time?

_I'm not sure if this is a math or Mathematica question, but I'm posting it here because I'm interested in possible Mathematica tools/functions to solve the problem._ I'm stuck. I want to simulate the effect of a EMP (ElectroMagnetic Pulse) disturbance on an FM signal. Here's my code:               f1[t_] := Sin[t]; (* baseband signal *)     f2[t_] := Sin[15 t]; (* carrier *)     f3[t_] := Sin[15 t + 8 f1[t]] ; (* antenna signal *)     f4[t_] := UnitTriangle[2 (t - 4)]; (* lightning EMP *)     f5[t_] := f3[t] + f4[t]; (* received signal *)     Plot[{f5[t], f1[t]}, {t, 0, 20}]      which results in this plot: ![enter image description here](http://i.stack.imgur.com/C19kk.png) So far so good, but here I am stuck. I want to demodulate the received signal to see the effect of the EMP on my baseband signal, and I don't know how to do this. The signal is there, I can _see_ it (and hear it when I listen to the radio). I prefer a continuous-time solution, because that's what my radio also works in, but if necessary a discrete-time solution is also welcome.


Plot a function over a specific domain

I have a function that is defined on a specific domain for example the function $$f(x,y)=(x-0.5)*(y-0.5)$$ defined on $\Sigma$ which is the circle $(x-0.5)^2+(y-0.5)^2=0.5^2$ How to plot $f$ over $\Sigma$? I tried something like               Plot3D[(-0.5 + x) (-0.5 + y), {x, -1, 1}, {y, -1, 1},      RegionFunction ->      Function[{x, y}, 0.5^2 - 0.01 <= (x - 0.5)^2 + (y - 0.5)^2 <= 0.5^2 + 0.01]]      but I am looking for something better.


Any way to fully expand an expression of two operators?

I am looking for a way to expand a complicate expression like the follow               (A o B + C o (DxE))*(D o (ExF) - ExA + A)      Here o and x are the operator. I want to expand it so to have it simplified as $$\sum_{n,m} G(f_n, g_m)$$ where G stands for operation (either o or x) of any variable $f_n$ and $g_m$, for example, $G(A, B)$ could be $A \,o\, B$ or $A \, \times\, B$. Also, o is commutable but x not, i.e. A o B = B o A, but A x B = - B x A. I am looking for a way to deal with any operator but up to now, for simplification, we could take o and x as dot product and cross product for real vector. After expanding the expression in above form, I would like to regulate each term so the number (coefficient) placed ahead of the vector. For example,               (p+aq)x(p+bq) => pxp + px(bq) + (aq)xp + (aq)x(bq) => pxp + b*(pxq) + a*(qxp) + (a*b)*(qxq)      where p and q are vectors, and a, b are numbers.


Upon PDF export, edgeless rectangles do not tile perfectly, and corners may be cut. Is this a bug?

**Note:** this problem is no longer present in version 10. * * * Exporting the following as a PDF file               Graphics[{       {Red, Rectangle[{0, 0}, {1, 1}]},       {Green, Rectangle[{1, 0}, {2, 1}]}     }]      does not produce perfectly tiled rectangles, and some of the corners are cut too, as shown here: ![rectangle with dog-ear, first example](http://i.stack.imgur.com/a0JWz.png) and here: ![rectangle with dog-ear, second example](http://i.stack.imgur.com/1W37n.png) Is this a bug? I solve the problem by giving them some tiny edges:               Graphics[{       EdgeForm[{Red, Thickness[Tiny]}],       {Red, Rectangle[{0, 0}, {1, 1}]},       EdgeForm[{Green, Thickness[Tiny]}],       {Green, Rectangle[{1, 0}, {2, 1}]}     }]      The rectangles are slightly larger, and their sizes are slightly different; practically this isn't a problem. But is there a more elegant solution?


FindFit: getting confidence intervals for the returned parameters

I'm using `FindFit[]` to fit a function to some experimental data. I'd like to know what error bars are on the fitted parameters. Scipy's `curve_fit()` returns the optimised parameters along with their covariance matrix - is there anything equivalent for Mathematica? As far as I can tell, there's no mention of it in the documentation.


Coloring with Hue for a function on a lattice grid

I wish to color a 2-dimensional lattice grid according to the value of a function at each lattice-node. More specifically, if I have 9 angles in a 3x3 array,               angles={{0, π, π}, {0, 0, π/2}, {π/2, 0, 3 π/3}}      then one can plot these angles on a lattice-grid by the following code in Mathematica:               angles = {{0, π, π}, {0, 0, π/2}, {π/2, 0, 3 π/3}};     GraphicsGrid[      Map[Graphics[{         LightGray, Circle[{0, 0}, 1],          Hue[#/(2 π), .6, .8], Thick, Arrowheads[Medium], Arrow[{{0, 0}, {Cos[#], Sin[#]}}]}] &,        angles, {2}]]      Here, the colouring is done using the Hue command according to the value of each angle. However, now I want to compute a function `f[i,j]`; to be more specific,               f[i_,j_]:=Cos[angles[[i + 1, j]] - angles[[i, j]]] + Cos[angles[[i, j+1]] - angles[[i, j]]];       with               angles[[n+1,i_]]:=angles[[1,i]];     angles[[i_,n+1]]:=angles[[i,1]];       i.e., the boundary conditions. In the first code, Hue is used with the `angles[[i,j]]` (through `#`), which is probably straightforward. But is it possible to use `f[i,j]` instead, where `f[i,j]` is defined as above? P.S. This question is related to: data visualization on a lattice grid Thanks! ## dbm P.S. The final code, thanks to BoLe's answers:               Clear["Global`*"];     n := 10     angles = Table[RandomReal[{-Pi, Pi}], {i, n}, {j, n}];     f[here_, down_, right_] := Cos[down - here] + Cos[right - here]     g[list_, {i_, j_}] :=       Module[{m, n}, {m, n} = Dimensions[list]; {list[[i, j]],         If[i != m, list[[i + 1, j]], -list[[1, j]]],         If[j != n, list[[i, j + 1]], -list[[i, 1]]]}]     GraphicsGrid[      MapIndexed[       Graphics[{LightGray, Circle[{0, 0}, 1],           Hue[Rescale[f @@ g[angles, #2], {-2, 2}, {0, 1}]], Thin,           Arrowheads[Small], Arrow[{{0, 0}, {Cos[#], Sin[#]}}]}] &,        angles, {2}]]


PDF on TransformedDistribution of two BinomialDistribution too slow

I'd been doing my own convolutions of distributions for some calculations, decided to use built-ins. With               p5 = TransformedDistribution[py + pz,        {Distributed[py, BinomialDistribution[7, .2]],         Distributed[pz, BinomialDistribution[7, .3]]}]          PDF[p5, 5]      getting the PDF takes an inordinate amount of time (as in 30+ seconds on the laptop I'm on at the moment, faster on my real machines of course, but still slow.) I'm guessing it is using `DiscreteConvolve` under the covers, which is itself inordinately slow IMO, but I'm pondering if I'm missing something obvious in the use of `TransformedDistribution`. Any ideas (or explanations) for the slowness appreciated.


Help on output formatting

Again, I am writing homework sheets. I have tried                a = "(portionOfCircle)";      SectorArea =  a * Pi * r^2       SectorArea =  a * Pi * r^2 // TeXForm      With[{a = "portionOfCircle"}, Defer[a * Pi * r^2 // TeXForm]]      I would like the output to be in LaTeX form such as $$\text{(portion of circle)}\cdot \pi r^2$$ instead my code will output $$\pi \text{(portion of circle)}\cdot r^2$$ Also, I would like                a = RandomChoice[{Pi/6, Pi/4, 5 Pi/4}]/(2 Pi)      SectorArea = a*Pi*r^2      SectorArea = a*Pi*r^2 // TeXForm      With[{a = a}, Defer[a*Pi*r^2]]      to output $$\frac{\pi/4}{2\pi}\cdot \pi r^2$$ instead, it simplifies the fraction hiding the concept i'm trying to emphasize. Any help would be much appreciated.


Strange spikes in my surface

I'm getting strange spikes in my surface `S` with the code below. `PlotPoints` seems to help, but it doesn't solve the problem. Any explanation and solution would be much appreciated.               a := {x, y, 1 - x}     b := {x, y, x}     S := Inner[Times,        Transpose[Inner[Times, {1 - x, x}, {{a /. {x -> 0, y -> 0}, b /. {x -> 0, y -> 1}},          {a /. {x -> 1, y -> 0}, b /. {x -> 1, y -> 1}}}, Plus]], {1 - y, y}, Plus]     ParametricPlot3D[S, {x, 0, 1}, {y, 0, 1}]     ParametricPlot3D[S, {x, 0, 1}, {y, 0, 1}, PlotPoints -> 100]     Expand[S]     ParametricPlot3D[{x, y, 1 - x - y + 2 x y}, {x, 0, 1}, {y, 0, 1}]      * * * EDIT: It seems that `y ->` is somehow responsible. ![enter image description here](http://i.stack.imgur.com/ZwLGK.png) ![enter image description here](http://i.stack.imgur.com/SEfF6.png) ![enter image description here](http://i.stack.imgur.com/2k2lX.png)


Making multiple sideways histograms/bell curves around temporal data

I don't quite remember what this type of plot is called, but here is the idea: I have some data which is indexed by time, and I want to look at the evolution of the distribution of that data as time progresses. To accomplish this, I want a discrete plot with times 1,2,...,n, and instead of a point at each time, I want a histogram or approximate bell curve aligned around the mean for that time. For example, if my data was               {{1,2,2,3},{2,3,3,4},{3,4,4,5}}      then above the t=1 point, I would want a small sideways histogram centered around 2, at t=2 I would want a small sideways histogram centered around 3, and at time 4 I would want a small sideways histogram centered around 4. I am sure that this is not an exotic type of graph, as I remember seeing a whole section about them in my stats book (from oh so long ago). Could anyone tell me what the name of this type of graph is, and how to make one in mathematica?


How do I determine the maximum value for a polynomial, given a range of x values?

I need to determine the maximum value for `y = a x^2 + b x + c`, where I know the coefficients and the upper and lower `x` values. Say the input values are:               a = 5; b = 1; c = 2; xLower = -5; xUpper  = 5;      Given this input, how do I determine the maximum value for the quadratic function above? My goal is to implement a function that has a signature such as `funcMax[ a, b, c, xUpper, xLower]`. How could I get the arguments for the extremal values using the above input?


use variables again after derivation

I have something the following form:               a= 3*k;     b=c*d*a;     h[k_]=b*k^3;      so if I use `l[k_]=D[h[k],k]` I get `12*c*d*k^3` but I would like to get it in the following form: `4bk^2` how do I do that?


Using AddTo in a function

I want to create a function that will take a variable $x$ and reassign the value $x+2$ to $x$. So               f[x_]:= x += 2      However:               f[10]      yields the _Mathematica_ error > AddTo::rvalue: 10 is not a variable with a value, so its value cannot be > changed. Which makes sense, as I am asking _Mathematica_ to assign the value of 12 to 10. So how can I do this so that it changes the assigned value of some variable $x$?


Simulate MATLAB's meshgrid function

Here is MATLAB's `meshgrid`. I came up with these implementations in _Mathematica_ :               {x, y} = With[{n = 10}, Table[#, {i, n}, {j, n}]] & /@ {j, i};      and               {x, y, z} = Array[List, {5, 5, 5}][[All, All, #]] & /@ {3, 2, 1}      but it seems that it's not fast enough. The following example is about three times slower than MATLAB.               (* Mathematica *)     (       {a, b} = With[{n = 3000}, Table[#, {i, n}, {j, n}]] & /@ {j, i};       c = a^2 + b^2 // N // Sqrt;       Compile[{}, Position[Unitize@FractionalPart@c, 0]][] // Length     ) // AbsoluteTiming                    %MATLAB     tic;     [a,b]=meshgrid(1:3000);     c=sqrt(a.^2+b.^2);     idx=find(c==round(c));     length(idx)     toc;      Can you recommend an efficient method? **Updated**               (       {a, b} = {#, Transpose@#} &@ConstantArray[Range@3000, {3000}];       c = Sqrt@N[a*a + b*b];       SparseArray[Unitize@FractionalPart@c~BitXor~1]["NonzeroPositions"] // Length     ) // AbsoluteTiming


Importing formatted, highlighted text from : HTML vs RTF vs. XML

We would like the ability to import and analyze ASCII documents that have been manually segmented by highlighting and changing font colors of various sections, eg: ![enter image description here](http://i.stack.imgur.com/wNWeP.png) The original line breaks, spacing and other formatting need to be preserved upon import, and in addition, need to extract the highlight or font color. To identify a suitable format we are using MS Word for highlighting because we can then save as .rtf, .htm and .xml. Clearly importing plain text won't contain highlight info, so on to structured formats: So far not having much luck with MMA9's RTF:               Import[NotebookDirectory[] <> "/example-highlighting-word.rtf", "RTF"]      gives:               Notebook[{Cell[        TextData[{"I found out some info",           " on this type of acrylic..  It is called an exotic type of \     acrylic that shows a colored edge when it is cut.  Comes in different \     color types but is not a stock item at San Diego Plastics and is \     pretty expensive.", "                                ", "Also, the cost of ",           "a 4' x 4' sheet of 1/2\" acrylic for my discount is $150.                     ", "Did you figure out the exact measurements of the two \     pieces.", "                     ", StyleBox["I ran some test pieces and they fit. ",            FontColor -> RGBColor[1., 0.4, 0.]],           StyleBox[           " I think we will have to get some new bolts for the larger \     pieces because the heads a", FontColor -> RGBColor[1., 0.4, 0.]],           StyleBox["re to", FontColor -> RGBColor[1., 0.4, 0.]],           StyleBox["o", FontColor -> RGBColor[1., 0.4, 0.]],           StyleBox[           " tall and I would have to make too deep of a cut to hide the \     bolt head; which would end up making a weaker attachment point.",            FontColor -> RGBColor[1., 0.4, 0.]], StyleBox["           ", FontSize -> 12, FontColor -> RGBColor[1., 0.4, 0.]]}],         "Input", CharacterEncoding -> "MacintoshRoman"]},       WindowSize -> {740, 867},       WindowMargins -> {{910, Automatic}, {Automatic, 239}},       FrontEndVersion ->        "9.0 for Mac OS X x86 (32-bit, 64-bit Kernel) (November 20, 2012)",       StyleDefinitions -> "Default.nb"]      Clearly the generated Notebook structure _doesn't match_ the original highlighting segments. Next we saved and then imported XML:               Import[NotebookDirectory[] <> "/example-highlighting-word.xml", "XML"]      And won't copy the output but it's lengthy, it breaks up individual sentences and the data schema is binary so would be difficult to write pattern rules to extract content and highlights. Finally, saving and importing HTML as "Text" looks promising:               Import[NotebookDirectory[] <>        "/example-highlighting-word.htm", "Text"]      The output is less voluminous than XML (though still lengthy), but there are still Word-specific HTML tags to deal with, for example:
I found out some info on this type \     of acrylic..  It is called an exotic type of acrylic \     that shows a     colored edge when it is cut.  Comes in different color types but \     is not a     stock item at San Diego Plastics and is pretty expensive.<o:p></o:p>
      Question - besides is RTF broken? - Is there documentation to handle and pattern match the MS-generated HTML tags like , and to discover potential variations in tags. For example, we'd like to recover the number of new-lines separating paragraphs (as well as indentations), but are faced with composite tags like the following that seems to represent a single newline in the original document:
 <o:p></o:p>
      Any better ways to go about it - ie, other formats or `Import` options? (It's not necessary to use MS Word, maybe other rich text editors are more conducive to proper RTF?)


Multiply (not divide!) Vectors in a List by Their Own Norm

I wanted a set ("list") of 100 random vectors of dimension 2. I accomplished this already by generating a "list of lists" where the elements of the overall list are 2-dimensional lists consisting of 2 random numbers. Of course, each of these 2-dimensional lists are the vectors, and there are 100 of them. I accomplished this as follows:               vectors = Transpose[{RandomReal[{-1, 1}, 100], RandomReal[{-1, 1}, 100]}]      I know that I can find the norm of each of those vectors by mapping the Norm function onto the overall list, like so:               norms = Map[Norm,vectors]      That is a list of 100 numbers. What I want to do now is multiply each of the vectors by their respective norms. (Note that I am not talking about normalizing them which could've simply been done by coding: `Map[Normalize,vectors]`.) Essentially, I'd like a one-to-one mapping where element 1 of the list "vectors" is multiplied by element 1 of the list "norms". I'm not sure how to do this. I thought of defining a new function where the argument would be a list (one of those 2-dimensional lists in the list "vectors" above) and the function would multiply the argument by its norm. However, I'm not sure how to program this function or if this is even an efficient way to do it. **How could I define this so-called one-to-one mapping?** (My ultimate goal is to plot my resulting vectors, and then run a loop doing this over and over many times.)


How do I designate arguments in a nested map?

Say I have two lists,               list1 = {a, b, c}     list2 = {x, y, z}      and I want to map a function f over them to produce               {f[a,x], f[a,y], f[a,z], f[b,x], f[b,y], f[b,z], f[c,x], f[c,y], f[c,d]}      I would assume I map the function over the first list to produce a "list of functions", which then run over the 2nd list, something like:               Map[Map[f[#1, #2]&,list1]&, list2]      but I can't figure out how to leave #2 "empty" until the 2nd map kicks in. How can I separate them to generate all combinations of arguments?


FindFit: why do I get negative value as result?

I am trying fo fit a model to data using `FindFit`.               J[i_, j_, α_, β_, xpos_, ypos_] := N[(β α^2*π)/4*((Erf[(j - xpos)/α ] -          Erf[(j + 1 - xpos)/α ])*(Erf[(i - ypos)/α ] - Erf[(i + 1 - ypos)/α ]))];      when entering the exact data Mathematica gives a negative result for parameter α. When I put constraints on α to be positive the output is even more strange. What do I miss?               data2 = Flatten[Table[{i, j, J[i, j, 5, 20, 3.5, 3.5]}, {i, 1, 5}, {j, 1, 5}], 1]          Plane = FindFit[data2, {(β α^2*π)/4*((Erf[(j - xpos)/α ]        - Erf[(j + 1 - xpos)/α ])*(Erf[(i - ypos)/α ] - Erf[(i + 1 - ypos)/α ]))},       {α, β, xpos, ypos}, {i, j}]      > {α -> -4.99999, β -> 20., xpos -> 3.5, ypos -> 3.5} thanks Now with the constrains:               Plane = FindFit[data2, {(\[Beta] \[Alpha]^2*\[Pi])/4*((Erf[(j - xpos)/\[Alpha] ] - Erf[(j + 1 - xpos)/\[Alpha] ])*(Erf[(i - ypos)/\[Alpha] ] - Erf[(i + 1 - ypos)/\[Alpha] ])), \[Alpha] > 0}, {\[Alpha], \[Beta], xpos, ypos}, {i, j}]      The output:               {\[Alpha] -> 21.4664, \[Beta] -> 58.4232, xpos -> 67.9514, ypos -> 67.9508}Plane = FindFit[data2, {(\[Beta] \[Alpha]^2*\[Pi])/4*((Erf[(j - xpos)/\[Alpha] ] - Erf[(j + 1 - xpos)/\[Alpha] ])*(Erf[(i - ypos)/\[Alpha] ] - Erf[(i + 1 - ypos)/\[Alpha] ]))}, {\[Alpha], \[Beta], xpos, ypos}, {i, j}] // Timing      {0.015600, {[Alpha] -> -5., [Beta] -> 20., xpos -> 3.5, ypos -> 3.5}} with Method-> NMinimize we get correct solution but X60 slower...               Plane = FindFit[data2, {(\[Beta] \[Alpha]^2*\[Pi])/4*((Erf[(j - xpos)/\[Alpha] ] - Erf[(j + 1 - xpos)/\[Alpha] ])*(Erf[(i - ypos)/\[Alpha] ] - Erf[(i + 1 - ypos)/\[Alpha] ]))}, {\[Alpha], \[Beta], xpos, ypos}, {i, j}, Method -> NMinimize] // Timing          {0.624004, {\[Alpha] -> 5., \[Beta] -> 20., xpos -> 3.5, ypos -> 3.5}}


Creating a Logarithmic Scale Plot

I am trying to plot a function on a `Log` scale, but am not getting the correct looking output. Any ideas on what could be wrong. `MWE` is below:                F1=500 10^3;      F2=50 10^3;      k1=(2\[Pi] F1)/\[Omega]c;      k2=(2\[Pi] F2)/\[Omega]c;      \[Omega]c=Sqrt[Power[2.0, (3)^-1]-1.];      K=6.0;      Av=10^(K/20);      frequencies=Table[f,{f,-6000,4000000,1000}];      \[Omega]=2\[Pi] f;      s=I \[Omega];      sL = s/k1;      sH = s/k2;      TL=Abs[(1/(sL+1))^3];      TH=Abs[(sH/(sH+1))^3];           TB=(Av)(TL)(TH);      LogPlot[20Log[10,TB],{f,10,2 10^3},PlotRange:>{-20,10}]      Seen `LogLogPlot` but not sure of the difference between the two.


expanding a polynomial and collecting coefficients

I'm trying to expand the following polynomial                 Expand[  (A1 a1 + A2 a2 + A3 a3 + A4 a4 + A5 a5 + A6 a6 + A7 a7 + A8 a8)                 (D1 a1 + D2 a2 + D3 a3 + D4 a4 + D5 a5 + D6 a6 + D7 a7 + D8 a8)              + (H1 a1 + H2 a2 + H3 a3 + H4 a4 + H5 a5 + H6 a6 + H7 a7 + H8 a8)                (E1 a1 + E2 a2 + E3 a3 + E4 a4 + E5 a5 + E6 a6 + E7 a7 + E8 a8)]       and collect terms (for example, rewrite this as                 (A1 D1 + ....+ H1 E1) a1^2 + (A1 D2 + ....) a1 a2 + (A1 D3 + ... ) a1 a3 + ...     + (A8 D8 + ... + ) a8^2 )      where I am thinking of the capital letters `A1, A2, ...., D1, D2, ... H1, H2, ..., E1, E2, ...` as some coefficients and `a_i`'s as variables. I could do this by hand but what if, instead of having `8` variables and two terms, I have `k` variables and `n` terms? Expanding the products and collecting terms by going through all the monomials by hand are doable but probably not that clever.


How can I regulate 'Play sound duration' in Mathematica 8

How can I regulate the time of play sound[s] - duration in Mathematica 8. I want to import and save wav file in *.nb document & manipulate (with) the sound duration, for example, select sound fragment, split etc. I can not present sounds with duration more than 5 or 7 seconds in wavelet form - problem with CPU or memory ("very large..."). Thank you for answers. * * * I really tried to solve the problem of primitive –               file="C:/**.wav";     data=Flatten@Import[file,"Data"];     Import[file,"Options"];     data=Import[file,"Sound"];     L=Length[data];  Manipulate[Sound[data,t],{t,0.1,L}]      it works, but probably not optimal. It works slowly. In general, my problem has arisen from a desire to manipulate with time (duration) of the wav sound file. Your perfect solution, since it allows to allocate the sample. Before that I was faced with freezing when trying to view 10-second file in the wavelet form. «No more memory available. Mathematica kernel has shut down. Try quitting other applications and then retry». I used the "Direct conversion of acoustic data" Mathematica code - Direct analysis of acoustic data using continuous wavelet transforms. http://www.wolfram.com/mathematica/new-in-8/wavelet-analysis/directly- transform-sound.html               snd = ExampleData[{"Sound", "Apollo11ReturnSafely"}]     cwd = ContinuousWaveletTransform[snd,        GaborWavelet[6], {Automatic, 12}]     sty = Directive[14, FontFamily -> "Helvetica"];     WaveletScalogram[cwd, {3 | 4 | 5 | 6 | 7, _}, ImageSize -> 570,       Ticks -> {Automatic, {#, Superscript[2, #]} & /@ Range[7]},       TicksStyle -> sty,  AxesLabel -> {Style["Time", sty], Style["Scale", sty]},       ColorFunction -> ColorData["SiennaTones"]]      But it hangs when I try to submit a file whose duration is 10 seconds or more. Maybe it depends on the record a sound file.


Performance of compiled functions

I am trying to find the fastest way to calculate two values where both of them are sum of different expressions. I combine both calculations in one `Sum[]`. I'm compiling into "C". Here are the test functions I have:               f = Compile[{{n, _Integer, 0}}, Module[{a},         Sum[Module[{}, a = Sin[-0.001 i^2]; {i*a, a}], {i, 1, n}]],         CompilationTarget -> "C", RuntimeOptions -> "Speed"];     g = Compile[{{n, _Integer, 0}}, Module[{a},         Sum[{i*Sin[-0.001 i^2], Sin[-0.001 i^2]}, {i, 1, n}]],         CompilationTarget -> "C", RuntimeOptions -> "Speed"];     h = Compile[{{n, _Integer, 0}}, Module[{a},         Sum[(a = Sin[-0.001 i^2]; {i*a, a}), {i, 1, n}]],         CompilationTarget -> "C", RuntimeOptions -> "Speed"];     q = Compile[{{n, _Integer, 0}}, Module[{},         {Sum[Sin[-0.001 i^2]*i, {i, 1, n}],           Sum[Sin[-0.001 i^2], {i, 1, n}]}], CompilationTarget -> "C",         RuntimeOptions -> "Speed"];     q2 = Compile[{{n, _Integer, 0}}, Module[{},         {Table[Sin[-0.001 i^2]*i, {i, 1, n}] // Total,           Table[Sin[-0.001 i^2], {i, 1, n}] // Total}],         CompilationTarget -> "C", RuntimeOptions -> "Speed"];     nc[n_] := {Sum[Sin[-0.001 i^2]*i, {i, 1, n}],         Sum[Sin[-0.001 i^2], {i, 1, n}]};     Benchmark[f_, n_] := Timing[f[n]];     TableForm[      Flatten /@ Table[Benchmark[fun, 10000], {fun, {f, g, h, q, q2, nc}}],       TableHeadings -> {{"f", "g", "h", "q", "q2", "nc"}, {"Timing",          "Result"}}]      I expect the function `h` to be the fastest because I'm reusing an expensive calculation of `Sin` or, if compiler is smart enough to implement the reuse, approximately same speed from all three. Instead functions `q` and `q2` are the fastest and `g` is way faster than the other compiled versions, with following results:                   Timing                Result         f   0.026824    104486. -34.6114     g   0.000782    104486. -34.6114     h   0.020543    104486. -34.6114     q   0.000597    104486. -34.6114     q2  0.000628    104486. -34.6114     nc  0.001784    104486. -34.6114      Why is this happening? My guess is evaluation escapes from compiled body, but why? **Update** Big thanks to halirutan for a good answer! For completeness I added the non- compiled version of his function `fHal`               fHalNoC[n_] :=        With[{r = Range[n]}, Total /@ ({r*#, #} &[Sin[-0.001 r^2]])];      Then with a slightly modified benchmark function:               testRange = 10^#  & @{3, 4, 5, 6};     Benchmark[f_, n_] :=        With[{results = Table[First@AbsoluteTiming[f[n]], {20}]},         Mean[results]];     TableForm[      Table[Benchmark[fun, n]/        n, {fun, {f, g, h, q, q2, nc, fHal, fHalNoC}}, {n, testRange}],       TableHeadings -> {{"f", "g", "h", "q", "q2", "nc", "fHal",          "fHalNoC"}, testRange}]      I got following results (I normalized timing over list length): ![benchmark results](http://i.stack.imgur.com/RjIdx.png) I guess my lesson learned: even non-compiled version that utilizes `Listable` is faster than my timid attempts to tune with compilation. Full code available here.


How to update a list in a function in each iteration

There is a list with numbers 1 to 8 ( `p1` ) and another list (`j`) which contains 4 numbers which shows different 4 positions of the elements in list `p1`. I want to take 4 elements from `p1` related to the 4 numbers of positions from the list `j` and multiply those selected 4 numbers from list `p1` by 2. The code below is a function that do the procedure that I have mentioned above :               p1 = {1, 2, 3, 4, 5, 6, 7, 8};          DoMul[p1_] := Module[{nmu, e1, j, mul, Replacement},     j = {1, 6, 7, 8};     i = 1; While[i <= 4,     e1 = Extract[p1, {j[[i]]}];     mul = 2*e1;     Replacement = ReplacePart[p1, j[[i]] -> mul];         ; i++];     Replacement];       The problem is that I do not know how to update `p1` in each iteration ( There are 4 iterations ) and the result will be :               {1, 2, 3, 4, 5, 6, 7, 16}      but the correct answer must be :               {2, 2, 3, 4, 5, 12, 14, 16}      Does anyone know how to update the `p1` list in each iteration?


How to fill in an irregular border of an image

I have the following code which draws a graphic, and colors the regions in it different colors:               g = {{Circle[#, 1 - Sqrt[2]/2] & /@ Tuples[0.5 {-1, 1}, 2]},           {Circle[{0, 0}, 1]}};          graphic = Graphics[GeometricTransformation[g, Tuples[Range[-2, 2], 2]]]      ![enter image description here](http://i.stack.imgur.com/BeTcT.png)               image = Rasterize[graphic, "Image", ImageSize -> 800];          regions = MorphologicalComponents[image, 0.9];          newimage = ImageResize[        Colorize[regions,            ColorFunction -> (ColorData["SolarColors", Mod[Sin[#^2], 1]] &),            ColorFunctionScaling -> False],         Scaled[0.5]        ]      ![enter image description here](http://i.stack.imgur.com/Xbk46.png) I'd like the color for the region that is outside all of the circles to be black. What's the best way to do this? (The ideal solution would still work if I set `PlotRangePadding -> None` on the original graphic, which will cause the exterior to be several components instead of just one.)


Defining functions from expressions of variable lengths

I have a list of symbols that I have defined using               d = Table[Symbol["d" <> ToString[i]], {i, 1, n}]       giving               d = {d1, d2, d3, d4, d5}      where n = 5 in this case. I use this as part of an argument to an interpolation, giving me               Vchamber = 0.111549 d1 - 0.101842 d2 + 0.857554 d3 - 1.09366 d4 + 2.24236 d5       Now I want to define a function that gives something like                fVchamber[d1_,d2_,d3_d4_,d5_] := 0.111549 d1 - 0.101842 d2 + 0.857554 d3 - 1.09366 d4 + 2.24236 d5       Now, n is variable. Hence, the argument list is variable, as is the expression Vchamber. I was hoping that something like                fVchamber[d__]:=Function[d,Vchamber]      would work but it doesn't. What am I doing wrong? I have looked for answers but I haven't found one yet.


Why is my plot so small?

This code               e12 = {10, 12, 15, 18, 22, 27, 33, 39, 47, 56, 68, 82, 100};     l12 = Log[e12];     l12m = Log[e12 0.9];     l12p = Log[e12 1.1];     LogLinearPlot[{}, {r, 10, 100}, Axes -> {True, False}, Ticks -> {e12},       PlotRange -> {0, 80},       Epilog ->  {{Table[{Dashed, Line[{{l12[[r1]], 0}, {l12[[r1]], 100}}]}, {r1, 1, 13}]},         {Table[{Line[{{l12m[[r1]], 5 + 5 r1}, {l12p[[r1]], 5 + 5 r1}}]}, {r1, 1, 13}]},         {Table[{Blue, Line[{{l12m[[r1]], 2}, {l12p[[r1]], 2}}]}, {r1, 1, 13}]},         {Table[{Line[{{l12m[[r1]], 3.75 + 5 r1}, {l12m[[r1]], 6.25 + 5 r1}}]}, {r1, 1, 13}]},         {Table[{Line[{{l12p[[r1]], 3.75 + 5 r1}, {l12p[[r1]], 6.25 + 5 r1}}]}, {r1, 1, 13}]}       }]      gives me this plot: ![enter image description here](http://i.stack.imgur.com/qQs7U.png) Any idea why it's so small?


Want Wolfram|Alpha to assume $n$ is an integer

I would rather use Wolfram|Alpha on my iPad then _Mathematica_ , so I need your answer to be applicable to W|A. I want to input a function or an expression in a way that Wolfram|Alpha will understand that my references to $n$ are references to an integer. For example, I want to simplify $\frac{-\cos(n \pi)}{n \pi}$ to something more comapct. How could this be achieved? Any suggestions?


plotting 3d points: z-axis is squashed

I am plotting 3D points and it occurs to me that Mathematica doesn't have an easy way to specify my points to be plotted in a uniformly scaled cartesian space. For example I plotted               Show[ListPointPlot3D[{{0, 0, 0}, {1, 2, 3}}], AspectRatio -> Automatic,  PlotRange -> Automatic]      And I get this: ![0,0,0 and 1,2,3](http://i.stack.imgur.com/rb0oi.png) I would like to be looking at a box with the dimensions 1,2,3, not something like 3,3,1. The AspectRatio and PlotRange do not help, by the way.


Dependent Manipulate sliders

I would like to use dependent sliders in `Manipulate`. First slider `K0` should be independent and varied from `Kmin` to `Kmax`. Two others sliders `K1` and `K2` should dependend on `K0` so that `K1*K2 == K0` should be always true. Is it possible?


FindRoot gives a wrong solution which obviously should not be there

I got stuck on FindRoot and I didn't see any similar problem posted, so let me explain what I am trying to do and what problem I meet here. I try to find roots of a particular function, which in the lowest order is just a second-order polynomial and hence can be solved by hand easily. However I want to generalize my code to compute situations of higher orders, in which will be transcendental equations, so it is still necessary to see things work correctly from the very beginning. Here is the code and the output in the lowest order:               a = FindRoot[(W -100 + I/2 (1 + 1/10))^2 + 1/4 == 0, {W, i I}, AccuracyGoal -> Infinity, PrecisionGoal -> MachinePrecision, WorkingPrecision -> MachinePrecision] // Hold     c = Table[{Re[(a // ReleaseHold)[[1, 2]]-100], Im[(a // ReleaseHold)[[1, 2]]]}, {i, -2, 0, 0.001}];     c = DeleteDuplicates[c, (Abs[#1[[2]] - #2[[2]]] < 0.1 &)];     ListPlot[c, PlotRange -> {{-4.2, 4.2}, {-1.5, 0.5}}, PlotMarkers -> Automatic]      ![poles of case 1](http://i.stack.imgur.com/4jvO7.png) so basically I create a table of different initial values, each one differs by 0.001, and use them to "scan" the position of roots on the complex plane by putting them into FindRoot one by one. Finally I get rid of duplicates by certain criteria and do a ListPlot. The result I expect is simply two complex numbers: 100-i/20 and 100-21i/20. However, no matter how I rewrite my code I always get three solutions (the middle one in the result of ListPlot, in which I shift the origin by 100). Only when I enlarge the grid size from 0.001 to 0.1 can I kill the extra solution which is obvious wrong. But this is really bothering me because when I go to higher orders, I expect to have more points in the region I plot. By that time I would certainly need a smaller grid size in order to do the scanning. For example, the next order I want to consider is the following:               a = FindRoot[(W -100 + I/2 (1 + 1/10))^2 + Exp[I W Pi/100]/4 == 0, {W, i}, AccuracyGoal -> Infinity, PrecisionGoal -> MachinePrecision, WorkingPrecision -> MachinePrecision] //Hold     c = Table[{Re[(a // ReleaseHold)[[1, 2]]-100], Im[(a // ReleaseHold)[[1, 2]]]}, {i, 100-4, 100+4, 10^-3}];     c = DeleteDuplicates[c, (Abs[#1[[2]] - #2[[2]]] < 0.1 &) || Abs[#1[[1]] - #2[[1]]] < 10^-9 &]     ListPlot[c, PlotRange -> {{-4.2, 4.2}, {-1.5, 0.5}}, PlotMarkers -> Automatic]      ![poles of case 2](http://i.stack.imgur.com/2mers.png) This time there will be infinite number of roots since now it's transcendental, but in the region I plot I still expect only two roots for physical reasons. However once again you can see that there is a third one right on the imaginary axis which shouldn't be there. (One can easily show that no root can locate on the imaginary axis by setting W=100+yi and separating the real part and imaginary part, but let me omit the analysis here.) Does anyone ever meet a similar situation? I really have no idea what's wrong here...I appreciate any suggestion/hint/answer! ps. this is my first time posting a question here, please let me know how I can improve my question to be more well-organized or well-defined. Thanks!


Fourier transform of sampled data

I have got some impulse response data that I would like to transform via `Fourier` to get the amplitude-frequency characteristics of the performing loudspeaker. The final goal is to show (e.g. via `ListDensityPlot`) how the calculated amplitude-frequency characteristics is dependant on the window I choose to transform (truncation of low frequencies). The issue I have is to get `Fourier` to behave like desired - I am unable to reproduce the frequency response that I got out of another 3rd part software. The issue: There is no `SampleRate` option for `Fourier` (and I got a sampling frequency of 48kHz) The following example illustrates the issues:               data = Table[Sin[x], {x, 0, 100}];          ListPlot[     Take[10*Log10[(Abs@Fourier[data, FourierParameters -> {1, -1}])^2],      Floor@(Length[Fourier[data, FourierParameters -> {1, -1}]]/2)],      Joined -> True, PlotRange -> Full]      ![fourier](http://i.stack.imgur.com/upOQF.png)               Periodogram[data, FourierParameters -> {1, -1}, SampleRate -> 1,      PlotRange -> Full, ScalingFunctions -> "dB"]      ![periodogram](http://i.stack.imgur.com/dZunU.png)


Series expansion: Taylor series takes huge amount of time

I'm working on a notebook, trying to expand the root of a cubic polynomial in Taylor series. When I type:               Series[(Sqrt[46656 a^2 - 864 (3 2^(1/3) a^(2/3) + 2 a B)^3] + 216 a)^(1/3) , {a, 0, 2}]       _Mathematica_ takes an indefinite amount of time and I am forced to halt execution. After this occurs, even simple functions like `Exp[x]` will not compute and I have to restart the kernel. Am I doing something wrong here? My computer is a month old, so I know the problem isn't old hardware.


Image processing - How can I apply an operation to several images at once?

I imported pictures into _Mathematica_ , and used names for them that follow the easy scheme "name" string joined with an integer, ranging from 14 to 20. Printing these images on screen works nicely:               Do[Print[ToExpression[StringJoin["name", ToString[i]]]], {i, 14, 20}]      However, applying operations like `ColorNegate[]` or `ColorReplace[]` instead of `Print[]` will result in neither any output nor error message. Is it possible to process several images at once?


Operations on elements of ragged lists

Suppose I have a list of lists with different lengths, sorted from longest to shortest                myLists = Sort[Table[RandomReal[1, RandomInteger[50]], {25}], Length@#1 > Length@#2 &];      I would like to add up all the first elements, then all the second, and so on elements for each list that has the required number of elements. For example if my lists are               {      {1,2,3},      {4,5},      {6}     }      Then I want to return               {11,7,3}      The following code performs this using For loops, but I am trying to figure out a better way of doing this.               sums = Table[0, {Max[Length /@ a]}];     (* For each row element up to the length of the longest list *)     For[j = 1, j <= Max[ Length /@ a], j++,     (* For each list *)          For[k = 1, k <= Length[a], k++,     (* Add the element to the correct sum if it exists *)                 If[Length[a[[k]]] >= j,                      sums[[j]] = sums[[j]] + a[[k, j]],                      Break[]                   ]             ]        ]


Creating an animated graph model based on equations

So I have a graph that looks like this               graph = Graph[{"Russia" \[DirectedEdge] "Crimea", "Russia" \[DirectedEdge]"Donetsk", "Russia" \[DirectedEdge] "Luhansk", "Russia" \[DirectedEdge] "Kharkiv", "Russia" \[DirectedEdge] "Sumy", "Russia" \[DirectedEdge] "Chernihiv", "Crimea" \[DirectedEdge] "Kherson", "Donetsk" \[DirectedEdge] "Luhansk", "Luhansk" \[DirectedEdge] "Donetsk", "Luhansk" \[DirectedEdge] "Kharkiv", "Kharkiv" \[DirectedEdge] "Luhansk", "Kharkiv" \[DirectedEdge] "Sumy", "Sumy" \[DirectedEdge] "Kharkiv","Sumy" \[DirectedEdge] "Chernihiv", "Chernihiv" \[DirectedEdge] "Sumy", "Donetsk" \[DirectedEdge] "Kharkiv", "Kharkiv" \[DirectedEdge] "Donetsk", "Kherson" \[DirectedEdge] "Zaporizhzhya", "Zaporizhzhya" \[DirectedEdge] "Kherson", "Zaporizhzhya" \[DirectedEdge] "Donetsk", "Donetsk" \[DirectedEdge] "Zaporizhzhya", "Kherson" \[DirectedEdge] "Dnipropetrovsk", "Dnipropetrovsk" \[DirectedEdge] "Kherson", "Dnipropetrovsk" \[DirectedEdge] "Zaporizhzhya", "Zaporizhzhya" \[DirectedEdge] "Dnipropetrovsk", "Dnipropetrovsk" \[DirectedEdge] "Donetsk", "Donetsk" \[DirectedEdge] "Dnipropetrovsk", "Dnipropetrovsk" \[DirectedEdge] "Kharkiv", "Kharkiv" \[DirectedEdge] "Dnipropetrovsk", "Kherson" \[DirectedEdge] "Crimea", "Dnipropetrovsk" \[DirectedEdge] "Poltava", "Poltava" \[DirectedEdge] "Dnipropetrovsk", "Poltava" \[DirectedEdge] "Kharkiv", "Kharkiv" \[DirectedEdge] "Poltava", "Poltava" \[DirectedEdge] "Sumy", "Sumy" \[DirectedEdge] "Poltava","Poltava" \[DirectedEdge] "Chernihiv", "Chernihiv" \[DirectedEdge] "Poltava", "Chernihiv" \[DirectedEdge] "Kiev", "Kiev" \[DirectedEdge] "Chernihiv", "Kiev" \[DirectedEdge] "Cherkassy", "Cherkassy" \[DirectedEdge] "Kiev", "Cherkassy" \[DirectedEdge] "Kirovohrad", "Kirovohrad" \[DirectedEdge] "Cherkassy", "Kiev" \[DirectedEdge] "Poltava", "Poltava" \[DirectedEdge] "Kiev","Poltava" \[DirectedEdge] "Cherkassy", "Cherkassy" \[DirectedEdge] "Poltava", "Kirovohrad" \[DirectedEdge] "Poltava", "Poltava" \[DirectedEdge] "Kirovohrad", "Kirovohrad" \[DirectedEdge] "Dnipropetrovsk", "Dnipropetrovsk" \[DirectedEdge] "Kirovohrad", "Kirovohrad" \[DirectedEdge] "Mykolayiv", "Mykolayiv" \[DirectedEdge] "Kirovohrad", "Mykolayiv" \[DirectedEdge] "Dnipropetrovsk", "Dnipropetrovsk" \[DirectedEdge] "Mykolayiv", "Mykolayiv" \[DirectedEdge] "Kherson", "Kherson" \[DirectedEdge] "Mykolayiv", "Mykolayiv" \[DirectedEdge] "Odessa", "Odessa" \[DirectedEdge] "Mykolayiv", "Odessa" \[DirectedEdge] "Kirovohrad", "Kirovohrad" \[DirectedEdge] "Odessa", "Odessa" \[DirectedEdge] "Vinnytsia", "Vinnytsia" \[DirectedEdge] "Odessa", "Vinnytsia" \[DirectedEdge] "Kirovohrad", "Kirovohrad" \[DirectedEdge] "Vinnytsia", "Vinnytsia" \[DirectedEdge] "Cherkassy", "Cherkassy" \[DirectedEdge] "Vinnytsia", "Vinnytsia" \[DirectedEdge] "Kiev", "Kiev" \[DirectedEdge] "Vinnytsia", "Vinnytsia" \[DirectedEdge] "Zhytomyr", "Zhytomyr" \[DirectedEdge] "Vinnytsia", "Zhytomyr" \[DirectedEdge] "Kiev", "Kiev" \[DirectedEdge] "Zhytomyr", "Vinnytsia" \[DirectedEdge] "Khmelnytsky", "Khmelnytsky" \[DirectedEdge] "Vinnytsia", "Khmelnytsky" \[DirectedEdge] "Zhytomyr", "Zhytomyr" \[DirectedEdge] "Khmelnytsky", "Khmelnytsky" \[DirectedEdge] "Rivne", "Rivne" \[DirectedEdge] "Khmelnytsky", "Rivne" \[DirectedEdge] "Zhytomyr", "Zhytomyr" \[DirectedEdge] "Rivne", "Vinnytsia" \[DirectedEdge] "Chernivtsi", "Chernivtsi" \[DirectedEdge] "Vinnytsia", "Chernivtsi" \[DirectedEdge] "Khmelnytsky", "Khmelnytsky" \[DirectedEdge] "Chernivtsi", "Chernivtsi" \[DirectedEdge] "Ternopil", "Ternopil" \[DirectedEdge] "Chernivtsi", "Ternopil" \[DirectedEdge] "Khmelnytsky", "Khmelnytsky" \[DirectedEdge] "Ternopil", "Ternopil" \[DirectedEdge] "Rivne", "Rivne" \[DirectedEdge] "Ternopil", "Rivne" \[DirectedEdge] "Lutsk", "Lutsk" \[DirectedEdge] "Rivne", "Lutsk" \[DirectedEdge] "Lviv", "Lviv" \[DirectedEdge] "Lutsk", "Lviv" \[DirectedEdge] "Ternopil", "Ternopil" \[DirectedEdge] "Lviv", "Lviv" \[DirectedEdge] "Ivano-Frankivsk", "Ivano-Frankivsk" \[DirectedEdge] "Lviv", "Ivano-Frankivsk" \[DirectedEdge] "Ternopil", "Ternopil" \[DirectedEdge] "Ivano-Frankivsk", "Ivano-Frankivsk" \[DirectedEdge] "Chernivtsi", "Chernivtsi" \[DirectedEdge] "Ivano-Frankivsk", "Ivano-Frankivsk" \[DirectedEdge] "Uzhgorod", "Uzhgorod" \[DirectedEdge] "Ivano-Frankivsk", "Uzhgorod" \[DirectedEdge] "Lviv", "Lviv" \[DirectedEdge] "Uzhgorod"}, VertexLabels -> "Name", ImagePadding -> 10]      Then I did so               trans = Transpose[Normal[AdjacencyMatrix[graph]]];     Total[Normal[AdjacencyMatrix[graph]]];     input = Table[0, {l, 1, 27}]; (input[[#]] = 1) & /@ Position[Total[Normal[AdjacencyMatrix[graph]]], 0] // Flatten; input      > >     {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, > 0, 0, 0} >   Coloured it in               grr = Graphics[{Red, PointSize[0.05], Point[{0, 0}]}];     grg = Graphics[{Green, PointSize[0.05], Point[{0, 0}]}];     AdjacencyGraph[Transpose[trans], ImageSize -> Medium,       VertexStyle -> Table[i -> If[input[[i]] == 1, Red, Green], {i, 1, 26}]]      Now I want to find a way to animate my graph. I want to attach a system of differential equations to each node and I want each node to turn `Red` (or stay `Green`) depending on whether the `x` comes out victorious or `y` (after say `t` amount of time) in say the following differential equations:               eqns = {x'[t] == a*y[t] - b*x[t], y'[t] == c*x[t] - d*y[t],x[0] == 60937, y[0] == 13797};      Where `c = (1-a)` and `d = (1-b)` and `a` and `b` are constants, but are different for each individual node (or _element_ ). How would I do this? `a` would be               {{"Crimea", 0.77}, {"Cherkassy", 0.067}, {"Chernihiv",0.103}, {"Chernivtsi",0.053}, {"Dnipropetrovsk", 0.32}, {"Donetsk", 0.749}, {"Ivano-Frankivsk", 0.018}, {"Kharkiv",0.443}, {"Kherson", 0.249}, {"Khmelnytskyi", 0.041}, {"Kirovohrad",0.035}, {"Kiev", 0.072}, {"Luhansk", 0.688}, {"Lviv", 0.038}, {"Mykolaiv", 0.293}, {"Odessa", 0.419}, {"Poltava",0.095}, {"Rivne", 0.027}, {"Sumy", 0.156}, {"Ternopil",0.012}, {"Vinnytsia", 0.047}, {"Lutsk", 0.025}, {"Zakarpattia",0.029}, {"Zaporizhzhya", 0.482}, {"Zhytomyr", 0.066}};      `b` would be               {{"Zhytomyr", 0}, {"Zaporizhzhya", 0.003}, {"Zakarpattia",0}, {"Lutsk", 0.008}, {"Vinnytsia", 0.001}, {"Ternopil",0.008}, {"Sumy", 0.006}, {"Rivne", 0.004}, {"Poltava",0.002}, {"Odessa", 0.021}, {"Mykolaiv", 0}, {"Lviv", 0.040}, {"Luhansk", 0.035}, {"Kiev", 0.622}, {"Kirovohrad", 0.001}, {"Khmelnytskyi", 0.002}, {"Kherson", 0.004}, {"Kharkiv",0.077}, {"Ivano-Frankivsk", 0.018}, {"Donetsk",0.127}, {"Dnipropetrovsk", 0.014}, {"Chernivtsi", 0.005}, {"Chernihiv", 0.002}, {"Cherkassy", 0.001}, {"Crimea",0.658}};      For each _element_.


MANIpulate. How to put labels and fit 24 vslides in a row?

How could I fit 24 vertical slides in a row?, in the up and How to add any reference like 0 and 8 ? and how to add 2 options boxes in the right under the vslides (or to the right of vlides??? What I want is similar to http://sensa.square7.ch/fit-snap0-4.jpg![enter image description here](http://i.stack.imgur.com/Mqucy.jpg)               Manipulate[{h1*h2*h3*h4},       Row[{Control[{h1, 0, 8}], Control[{h2, 0, 8}], Control[{h3, 0, 8}],         Control[{h4, 0, 8}], Control[{h5, 0, 8}], Control[{h6, 0, 8}],         Control[{h7, 0, 8}], Control[{h8, 0, 8}], Control[{h9, 0, 8}],         Control[{h10, 0, 8}], Control[{h11, 0, 8}], Control[{h12, 0, 8}],         Control[{h13, 0, 8}], Control[{h14, 0, 8}], Control[{h15, 0, 8}],         Control[{h16, 0, 8}], Control[{h17, 0, 8}], Control[{h18, 0, 8}],         Control[{h19, 0, 8}], Control[{h20, 0, 8}], Control[{h21, 0, 8}],         Control[{h22, 0, 8}], Control[{h23, 0, 8}], Control[{h24, 0, 8}]}],       ControlType -> VerticalSlider, ControlPlacement -> Up]


Is it possible to speed up ContourPlot on multi-core machines?

It is not very difficult to face a function for which `ContourPlot` works too slow. And it seems natural that this function can be parallelized well. Anyway, naive `Parallelize@ContourPlot` produces " _ContourPlot[...] cannot be parallelized;_ "... So, is it possible to parallelize ContourPlot?


How to plot the contour of the radius part of a complex function

Suppose we have a complex function $f(x,y)$, in which x and y are real variables. In theory we can write the function into the polar form $$ f(x,y)=r(x,y)e^{i\theta(xy)} $$ where $r(x,y)$ and $\theta(x,y)$ are real functions. For some complicated function, it may very difficult to see what $r(x,y)$ and $\theta(x,y)$ are. So my question is if given a the function $f(x,y)$, is it possible to plot the contour of the function $r(x,y)$: $$r(x,y)=0$$ ? For example,               f[x_, y_] := (Cos[x] + Cos[y]) Exp[I x y]      how can I reproduce the contour of `(Cos[x] + Cos[y])==0` only using $f[x,y]$?               Grid@{{ContourPlot[Re@f[x, y] == 0, {x, 0, 4 Pi}, {y, 0, 4 Pi},          ImageSize -> 300],        ContourPlot[Im@f[x, y] == 0, {x, 0, 4 Pi}, {y, 0, 4 Pi},          ImageSize -> 300]}, {        ContourPlot[(Cos[x] + Cos[y]) == 0, {x, 0, 4 Pi}, {y, 0, 4 Pi},          ImageSize -> 300],        ContourPlot[Abs[f[x, y]] == 0, {x, 0, 4 Pi}, {y, 0, 4 Pi},          ImageSize -> 300]}}      ![enter image description here](http://i.stack.imgur.com/mMlLc.png) Here is more complicated function just for check               f[a_, a0_, k_, K0_]:=E^(I a0 K0) (2 a - I k) LegendreP[2, (I k)/a, -Tanh[(a a0)/2]] (E^(I a0 K0)LegendreQ[1, (I k)/a, -Tanh[(a a0)/2]] - LegendreQ[1, (I k)/a, Tanh[(a a0)/2]]) - (2 a - I k) LegendreP[2, (I k)/a, Tanh[(a a0)/2]] (E^(I a0 K0) LegendreQ[1, (I k)/a, -Tanh[(a a0)/2]] - LegendreQ[1, (I k)/a, Tanh[(a a0)/2]]) + E^(I a0 K0)LegendreP[1, (I k)/a, -Tanh[(a a0)/2]] (I E^(I a0 K0)k LegendreQ[2, (I k)/a, -Tanh[(a a0)/2]] + (2 a - I k) LegendreQ[2, (I k)/a, Tanh[(a a0)/2]]) + LegendreP[1, (I k)/a, Tanh[(a a0)/2]] (E^(I a0 K0) (2 a - I k) LegendreQ[2, (I k)/a, -Tanh[(a a0)/2]] + I k LegendreQ[2, (I k)/a, Tanh[(a a0)/2]] + 4 a E^(I a0 K0)LegendreQ[1, (I k)/a, -Tanh[(a a0)/2]] Tanh[(a a0)/2]) - 2 a (LegendreP[1, (I k)/a, Tanh[(a a0)/2]] LegendreQ[2, (I k)/a, Tanh[(a a0)/2]] + E^(I a0 K0)LegendreP[1, (I k)/a, -Tanh[(a a0)/2]] (E^(I a0 K0)LegendreQ[2, (I k)/a, -Tanh[(a a0)/2]] + 2 LegendreQ[1, (I k)/a, Tanh[(a a0)/2]] Tanh[(a a0)/2]))          With[{a0 = 10., a = 1.4},      Row@{ContourPlot[         Re[f[a, a0, k, K0]] == 0, {K0, -2 \[Pi]/a0, 2 \[Pi]/a0}, {k, 0,           4}, ImageSize -> 400, PlotLabel -> "Re"],        ContourPlot[         Im[f[a, a0, k, K0]] == 0, {K0, -2 \[Pi]/a0, 2 \[Pi]/a0}, {k, 0,           4}, ImageSize -> 400, PlotLabel -> "Im"]}]      ![enter image description here](http://i.stack.imgur.com/tFbA9.png) and I expect to get something like this ![enter image description here](http://i.stack.imgur.com/6DVFV.png) Note that this question is related to my another question here, where I tried to plot the contour of $$ |f(x,y)|=|r(x,y)|=0 $$ but it turned out that plot the zero contour of a non-negative function is hard, since `ContourPlot` seems to be based on the Intermediate Value Theorem. Jens gives a manual approach in that question, but my future functions would be complicated Legendre and Hypergeometric functions, which would be a pain to manually deal with them by hand. So here I'm asking for maybe some alternative approaches to plot $r(x,y)=0$, if there are any.


Problem with EllipticE documentation

The complete elliptic integral of the second kind, `EllipticE`, is defined as,               Integrate[Sqrt[1-m Sin[t]^2],{t,0,z}]      According to the version 8 docs, the first of the "Possible Issues" is supposed to evaluate `Integrate[Sqrt[1-m Sin[t]^2],{t,0,z}]` as               If[(m Sin[z]^2 \[NotElement] Reals ||          Re[m Sin[z]^2] <= 1) && (Csc[z]^2/m \[NotElement] Reals ||          Re[Csc[z]^2/m] <= 0 || Re[Csc[z]^2/m] >= 1) &&          2 + m Cos[2 z] != m,        EllipticE[z, m],        Integrate[Sqrt[1 - m Sin[t]^2], {t, 0, z}, Assumptions ->           2 + m Cos[2 z] == m || (((2 - m + m Cos[2 z]) Csc[z]^2)/m \[Element] Reals && -2 <         Re[((2 - m + m Cos[2 z]) Csc[z]^2)/m] < 0) || (Re[m Sin[z]^2] >         1 && m Sin[z]^2 \[Element] Reals)]]      whereas I get simply               EllipticE[z,m]      Is this a bug in the docs?


Is there an equivalent of FullGraphics for Graphics3D?

For 2D graphics, there exists the function `FullGraphics` to turn the stuff Mathematica generates automatically on `Graphics` (like axes) into explicit graphics primitives. However that function doesn't work on `Graphics3D` objects. So is there some (possibly undocumented) function which does the same for 3 dimensional graphics?


Faster Ways to compute recursive summation

It takes a long time to compute the summation below, and I'd like to know if there are some better ways to compute things faster. I have used $3$ ways to calculate, but they are very unsatisfactory. I have a list named `cu` with around $8000$ **different** members with all rational numbers, and I expect that Mathematica can give me a result with a reasonable time.               Clear[b, k, mu];     b[0] := 1;     b[k_] := ( b[k] = Sum[Binomial[k - 1, m - 1] cu[[m]] b[k - m], {m, 1, k}] );     AbsoluteTiming[ mu = ParallelTable[b[k], {k, 20}]; ]     (* {0.0090005, { ... } } *)       As this recursive definition is not good in computing, I also try to use Faa di Bruno formula and Bell polynomial to calculate.               Clear[b, k, mu];     AbsoluteTiming[ mu = ParallelTable[BellY[Table[{1, cu[[n]]}, {n, k}]], {k, 20}]; ]     (* {0.0220012, { ... } } *)      0.02s are needed for only $20$ terms, then it will be too slow for all $5000$ terms. Hence I also think whether procedural programming implementation is useful.               Clear[b, k, mu];     AbsoluteTiming[ For[k = 1; mu = {}; mu[[0]] = 1, k <= 20, k++,      mu = Append[mu, Sum[Binomial[k - 1, n - 1] cu[[n]] mu[[k - n]], {n, 1, k}]]]; ]     mu = List@Delete[mu, 0];     (* {0.0020001, ... } *)      Unfortunately, it is not good for more terms. Can anyone provide me some methods in Mathematica to calculate as quick as possible? Thanks in advance.


Why does Arrow not work well with Scaled coordinates in 3D?

I am a little puzzled by the fact that if I try to use `Arrow` with `Scaled` coordinates in 3 dimensions the arrowheads are all over the place. Note `Arrow` _should_ work with `Scaled` coordinates as it is mentioned in the relevant documentation. So while this:               pt2D = (Scaled /@ RandomReal[{0, 1}, {2, 2}]);      works fine:               Graphics@{Arrow@#}& @ pt2D      ![enter image description here](http://i.stack.imgur.com/q7cYK.png) this:               pt3D = (Scaled /@ RandomReal[{0, 1}, {2, 3}]);      gives the arrowhead detached from the arrow:               Graphics3D@{Arrow@#}& @ pt3D      ![enter image description here](http://i.stack.imgur.com/4M8D7.png) and the same thing happens with `Tube`d arrows. Here's one from the middle to the edge of a plot:               Show[Plot3D[Sin[x - y], {x, 0, 2 π}, {y, 0, 2 π}, PlotStyle -> Green],       Graphics3D[{Arrow[Tube[#]]}& @ {Scaled[{0.5, 0.5, 0.5}],Scaled[{1, 1, 1}]}], ImageSize -> 200]      ![enter image description here](http://i.stack.imgur.com/4cUV0.png) Is this in any way expected behaviour? If not, can anyone recommend an easy fix?


Why does PolynomialQ[x^n, x] return False?

From what I can see `PolynomialQ` will return `False` whenever some exponent is another variable such as here:                   PolynomialQ[x^n, x]      Is there an alternative test that will return `True` for such a polynomial? **Motivation:** In another thread I need to use               Product[x^k (1 - x^k), {k, 1, n}]      for which _Mathematica_ returns:               x^(1/2 n (1 + n)) QPochhammer[x, x, n]      However those two forms do not expand in the same way, for instance with $n=3$:               With[{n = 3},       Expand[{x^(1/2 n (1 + n)) QPochhammer[x, x, n], Product[x^k (1 - x^k), {k, 1, n}]}]]     (* {x^6 QPochhammer[x, x, 3], x^6 - x^7 - x^8 + x^10 + x^11 - x^12} *)      Indeed, _Mathematica_ treats only the second expression as a polynomial:               With[{n = 3}, PolynomialQ[#, x] & /@        {x^(1/2 n (1 + n)) QPochhammer[x, x, n], Product[x^k (1 - x^k), {k, 1, n}]}]     (* {False, True} *)      even if I specify that n is integer as follows               f[x_, n_Integer] := x^(1/2 n (1 + n)) QPochhammer[x, x, n];     PolynomialQ[f[n], x]     (* False *)


Fitting data involving units

I want to fit some data to a model. However, if the data involves units in the independent variable, fitting seems not to work. As an example, consider the code               data = Table[{Quantity[t, "d"], Exp[-.1*RandomReal[{.9, 1.1}]*t]}, {t,0, 100}];     nlm = NonlinearModelFit[data, Exp[-a*t], a, t]      The goal is to have parameter estimates with the right units depending on the units appearing in data to minimize the risk of performing incorrect unit conversions manually. Any suggestions?


How to change the MATHEMATICA_USERBASE directory

I’ve found, from reading the help on MathKernel in the help system and in a number of questions here, that to make that change in Windows at least one apparently needs to enter “MathKernel … options” in a “Command Prompt” window. Which works, at least partly, but the MathKernel documentation is notably lacking in specifying the syntax required. I’ve tried (along with several similar ones) the following:   1. MathKernel MATHEMATICA_USERBASE= D:\WorkB\Mathematica,   2. MathKernel MATHEMATICA_USERBASE D:\WorkB\Mathematica, and    3. MathKernel MATHEMATICA_USERBASE->D:\WorkB\Mathematica The first two “work” in that a Kernel window opens, but querying $UserBaseDirectory in the Kernel window indicates that that directory has not been changed from the default (C:\Documents and Settings\User\Application Data\Mathematica). And the third one produces an “Access is denied” message in the Command Prompt window, but I don’t know whether that was due to the Command Prompt or to the MathKernel complaining about the syntax or the operation itself. So, what is the syntax required to change that environment variable through the MathKernel command? Which is apparently the recommended or required procedure according to Wolfram. Or, is there another way of doing that?


Why plot returns empty in this example?

Let me rewrite this question, showing the original problem, as it is more subtle than the simple example I showed before using `Sin[t]`. Here we go again. When I write this:               foo[$s_,$t_]:=Module[{s=$s,t=$t,r},     r= OutputResponse[TransferFunctionModel[Evaluate[1/(s^2+2*s+1)],s],UnitStep[t],t];     Plot[Chop@First@r,{t,0,20}]     ];     foo[s, t]      I get an empty plot. But when I write this               foo[s_,t_]:=Module[{r},     r= Chop@First@OutputResponse[TransferFunctionModel[1/(s^2+2*s+1),s],UnitStep[t],t];     Plot[r,{t,0,20}]     ];     foo[s, t]      I do not get an empty plot. My question is: Why first example above does not produce a plot? I know it has to do with how 's' and 't', the free parameters, to the calls to `TransferFunctionModel[]` and `OutputResponse[]`. But I do not see exactly why that is. thanks,


Reading Error Message from Mathematica using Mathlink C++

I am developing an UI on Visual Studio C++ and communicating with Mathematica using Mathlink. I create a function via Mathlink and in that function, I coded in such a way that it gives a message before being aborted. The output I get on Mathematica is:               Error::nnarg: The argument is not greater than or equal to zero     Out[38]= $Aborted      From Mathlink, I can actually read the $Aborted using MLGetString() I would want to actually read the error message as well. Is it possible? Thanks


How to minmize the memory problem in a compile function for a given code?

n =3; (*Number of atoms*) L = 3 (*No=umber of atomic levels*);     CT[xk_]:=CT[xk]=ConjugateTranspose[xk]          Fx[xk_]:=Fx[xk]=FixedPoint[ArrayFlatten,xk]          gb[k_] = {{1},{0},{0}};     eb[k_] = {{0},{1},{0}};     rb[k_] = {{0}, {0}, {1}};     e1[l_] = Table[{KroneckerDelta[l, m]}, {m, L}];     σ[l_, m_] = e1[l].Transpose[e1[m]];          Hop[t_, k_] = g[t] gb[k].CT[eb[k]] + g[t] eb[k].CT[gb[k]]+ Ω[t] rb[k].CT[eb[k]] + Ω[t] eb[k].CT[rb[k]];          I1[i_Integer]:=I1[i]=IdentityMatrix[L^(i-1)];          I2[i_Integer]:=I2[i]=IdentityMatrix[L^(n-i)];          Hn[t_]=Sum[Fx[I1[i]\[TensorProduct]Hop[t,i]\[TensorProduct]I2[i]],{i,n}];          PrrρT[i_Integer]:= PrrρT[i]=Fx[I1[i]\[TensorProduct]Transpose[σ[2,3]]\[TensorProduct]I2[i]]          PeeρT[i_Integer]:= PeeρT[i]=Fx[I1[i]\[TensorProduct]Transpose[σ[1,2]]\[TensorProduct]I2[i]]          Prrρ[i_Integer]:= Prrρ[i]=Fx[I1[i]\[TensorProduct]σ[2,3]\[TensorProduct]I2[i]]          Peeρ[i_Integer]:= Peeρ[i]=Fx[I1[i]\[TensorProduct]σ[1,2]\[TensorProduct]I2[i]]          Hint[p_] = Sum[If[i < j, 10.0 (2 Ω0^2)/ Sqrt[2. Ω0^2 + Γe^2/4.]      PrrρT[i].Prrρ[i].PrrρT[j].Prrρ[j],0], {i, n}, {j, n}];          Hfinal[t_] = Hn[t] +  Hint[p];          Lfull[X_?MatrixQ,t_?NumericQ]=Sum[     (-Γr/2 X.#1.#2-Γr/2 #1.#2.X+Γr #2.X.#1     -Γe/2 X.#3.#4-Γe/2 #3.#4.X+Γe #4.X.#3     )&[PrrρT[i],Prrρ[i],PeeρT[i],Peeρ[i]]     ,{i,n}];          (*Numerical Values*)     MHz = 2. N[π] 10^6; kHz = 2. N[π] 10^3;μs=1. 10^-6;          g[t_] = Ω0 N[Exp[-((t - tmax/2. - tmax/8.)^2/(2. (tmax/8)^2.))]];     Ω[t_] = g0 N[Exp[-((t - tmax/2. + tmax/8.)^2/(2. (tmax/8)^2.))]];     Γe = (38.0 MHz)/(2N[π]); Γr = (1. kHz)/(2N[π]);     Ω0 = 3. MHz; g0 = 3. MHz; tmax = 30. 10^-6;           (*Compile Function*)     m1 = With[{H1=Hfinal[t]},Compile[{{X, _Complex, 2}, {t, _Real}},      -I (H1.X - X.H1)+Lfull[X,t]]];          Fun[X_?MatrixQ,t_?NumericQ]:=m1[X,t];          mmu = MaxMemoryUsed[];          sol=NDSolve[{σ'[t]==Fun[σ[t],t],     σ[0]==Table[If[i == 1 ∧ j == 1,1.,0.],     {i,L^n},{j, L^n}]},σ[t],{t,0,tmax}, MaxStepSize -> 0.01,      MaxSteps -> 10^5 ];          mmu1=MaxMemoryUsed[]- mmu      If I consider n=6, then the NDSolve function is not working because of large memory problem...Please help me with this issue...


Multi-objective genetic algorithm in Mathematica?

Is there any implementation of a multi-objective genetic algorithm for Mathematica?


Picking numbers within a list with an interval of 60

I have a list of integers from 1 - 400. I choose `n` random numbers with replacement from the list. Here is an example:               list =        {5, 14, 15, 29, 38, 100, 112, 139, 156, 165, 195, 217,         228, 237, 249, 286, 320, 323, 325, 329, 335, 349}      If I have this list, the routine should find all the sublists with all the elements within 60 of each other               {{5, 14, 15, 29, 38}, {14, 15, 29, 38}, {15, 29, 38}, {29, 38},       {100, 112, 139, 156}, {112, 139, 156, 165}, {139, 156, 165, 195},       {156, 165, 195}, {165, 195, 217}, {195, 217, 228, 237, 249},       {217, 228, 237, 249}, {228, 237, 249, 286}, {237, 249, 286}, {249, 286},      {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349},       {323, 325, 329, 335, 349}, {325, 329, 335, 349}, {329, 335, 349}, {335, 349}}      `list`, in this case is sorted but that will generally not be true. I have a small program working now but it is less general and very slow. Can something be done here? Here is my code:               between[l_] := Module[{},          h = TakeWhile[l, # <= l[[1]] + 60 &];         s = Drop[s, 1];         h     ]               s = Sort[RandomChoice[Range[400], 22]];     Table[between[s], {Length[s] - 7 + 1}]


Mouse click on BarChart elements

What I would like to do is explore a data set by clicking on elements in a BarChart. I have some existing code which uses a manipulate which I was hoping to modify.               classification = {"class1", "class2", "class3"};     cause = {"cause1", "cause2", "cause3", "cause4", "cause5"};     dataSet = Table[{classification[[RandomInteger[{1, 3}]]],     cause[[RandomInteger[{1, 5}]]], RandomReal[{0, 10}]}, {i, 1, 50}];          (*generate the classification BarChart*)     byClass = GatherBy[dataSet, #[[1]] &];     durationByClass = {First[#][[1]], Total[#[[All, 3]]]} & /@ byClass;     classChart = BarChart[durationByClass[[All, 2]],      ChartLabels -> durationByClass[[All, 1]],      ChartStyle -> {LightGray, LightGray, LightGray},      PlotLabel -> "Data by Classification", ImageSize -> 400];          (*a function to get the cause chart*)     getCauseChartExample[classificationIndex_] := Module[{},     durationByCause = GatherBy[     Select[dataSet, #[[1]] ==         classification[[classificationIndex]] &], #[[2]] &];     plotData = {First[#][[2]], Total[#[[All, 3]]]} & /@ durationByCause;     BarChart[plotData[[All, 2]], ChartLabels -> plotData[[All, 1]],      ChartStyle -> LightGray,     PlotLabel -> classification[[classificationIndex]] <> " by Cause",      ImageSize -> 400]     ]          Manipulate[Row[{classChart, getCauseChartExample[classIndex]}], {classIndex, {1,2, 3}}]      The output looks like this; ![enter image description here](http://i.stack.imgur.com/zHbfu.png) I would like to replace the Manipulate with the ability to mouse click the bars on the chart on the left and have the corresponding chart display on the right.


My algorithm produces too many permutations

Imagine the following problem. A population of size $n$ consists of $i$ men and $n-i$ women. The population goes to the casino. Call $g_m$ ,$g_w$ the amount of money won by men and women respectively. The event that men win $j$ dollars and women $k$ dollars occurs with probability $p_{jk}$. These probabilities are constant and the number of possible values of {$g_m$,$g_w$} is equal to $q$, finite. A visit to the casino constitutes then a multinational trial. Now I want to determine the distribution of money won by men and by women after $x$ casino visits. My strategy was the following: (1) I define a multinational distribution with               D = MultinomialDistribution[x, Pjk];      (2) There are $q$ pairs of {${g_m,g_w}$} for which the probability is higher than zero. I take each integers partition of the number of attempts $x$, (assume the integerspartition is of size $h$) add $q-h$ zeros so to obtain a vector of size $q$ and find all the permutations for this vector. This routine finds all the possible realizations of the $x$ visits.               P = IntegerPartitions[s];     For[k = 1, k < Length[P] + 1, k++,        Vec = Join[Vector, Permutations[Join[P[[k]], ConstantArray[0, j -Length[P[[k]]]]]]]];      (3) Let $G=${${g_m,g_w}$} be the vector of all possible outcomes after a casino visit. I define a function Visits that find the probability for the sum of gained money for men and women:                 Visits[C_]:=Module[{}, Join[Total[C*G], {PDF[D, C]}]];      (4) Finally, we gather all entries in the obtained distribution that represent the same outcomes by summing the respective probabilities               SumD = Flatten[{#[[1, {1, 2}]], Total[#[[All, 3]]]}] & /@         GatherBy[Map[Visits, Vec], #[[{1, 2}]] &];      **Problem with this approach:** When the size of $G$ is relatively high (around 80) and the number of visits $x>=4$, the size of the array of permutations exceeds $2^{31}$. Is there a way to get around this? Is it possible for example to write the permutations directly to a file instead of storing them in an array?


Retrieve style definitions

How can I retrieve the style definitions of a certain style within a cell, notebook or stylesheet? For example how can I retrieve the `FontColor` and `FontFamily` of the `"Input"` style either in the current notebook or in `Default.nb`? (Preferably without reference to an existing cell of this style.)


How do I set the font for output in my stylesheet?

I'd like to change the font that _Mathematica_ uses for output by setting the font of the corresponding style in my stylesheet; bit simply overriding the default `Output` style with               Cell[StyleData["Output"],FontFamily->"Open Sans",FontSize->12]      seems to have no effect. Is there a way to do this that I'm missing? Is the style used for output something different? * * * Note that this is not a duplicate of "Set default font for Output", despite the title.


data clustering

I have some data set which i would like to partition into 3 groups a:set 1 b: set 2 c: background. I use `FindClusters[]` function but as you can see (after evaluating the commands) the result is not what I am looking for.   Can someone help?               data1 = RandomReal[{-0.1, 0.1}, {10^2, 2}];     data2 = RandomReal[{-1, 1}, {2*10^2, 2}];     data3 = RandomReal[{-0.3, -0.2}, {2*10^2, 2}];     data5 = Join[data1, data2, data3];     ListPlot[FindClusters[data5, 3]]      ![enter image description here](http://i.stack.imgur.com/faXuR.png)


Merging different size, different order table

I'm a beginner in Mathematica, so this may be a simple request. I have generated some columns of names and data. I want to merge them into a single list of names, with a column for each attribute. However, not all names are in each list, and I have had some problems ordering by the "Name" column. Here are the lists               {      {"Name", "Friend BC"},      {"Bru-2", 25.1333},      {"Al-1", 34.5667},      {"Dave-4", 0.},      {"Hal-8", 1.33333},      {"Leo-12", 7.06667},      {"Pat-16", 1.33333},      {"Ned-14", 1.18333},      {"Chas-3", 4.83333},      {"Sam-19", 1.18333},      {"Ed-5", 61.6667},      {"Ian-9", 4.2},      {"Ken-11", 1.7},      {"Quinn-17", 0.733333},      {"Unwin-21", 0.733333},      {"Frank-6", 33.1333},      {"Gra-7", 0.},      {"Jo-10", 44.2833},      {"Tom-20", 0.},      {"Mal-13", 0.},      {"Ollie-15", 35.9167}     }               {      {"Name", "Advice BC"},      {"Sam-19", 0.},      {"Mal-13", 0.},      {"Leo-12", 0.},      {"Ian-9", 0.},      {"Pat-16", 0.},      {"Dave-4", 0.},      {"Tom-20", 0.0769231},      {"Quinn-17", 0.0769231},      {"Ned-14", 0.0769231},      {"Ken-11", 0.0769231},      {"Jo-10", 0.0769231},      {"Gra-7", 0.0769231},      {"Frank-6", 0.0769231},      {"Unwin-21", 0.0769231},      {"Ron-18", 0.0769231},      {"Hal-8", 0.0769231},      {"Bru-2", 0.0769231},      {"Al-1", 5.74359},      {"Ed-5", 38.5},      {"Chas-3", 38.5},      {"Ollie-15", 70.4103}     }      I want the final table to be               {      {"Name", "Advice BC","Friend BC"},      {"Sam-19", 0., 1.18333},      {"Mal-13", 0., 0.},      {"Leo-12", 0., 7.06667},      {"Ian-9", 0., 4.2},      {"Pat-16", 0., 1.3333},      {"Dave-4", 0., 0.},      {"Tom-20", 0.0769231, 0.},      {"Quinn-17", 0.0769231, 0.73333},      {"Ned-14", 0.0769231, 1.18333},      {"Ken-11", 0.0769231, 1.7},      {"Jo-10", 0.0769231, 44.2833},      {"Gra-7", 0.0769231, 0.},      {"Frank-6", 0.0769231, 33.1333},      {"Unwin-21", 0.0769231, 0.73333},      {"Ron-18", 0.0769231, 0.},      {"Hal-8", 0.0769231, 1.3333},      {"Bru-2", 0.0769231, 25.1333},      {"Al-1", 5.74359, 34.5667},      {"Ed-5", 38.5, 61.6667},      {"Chas-3", 38.5, 4.8333},      {"Ollie-15", 70.4103, 35.9167},      {"Sam-19", 0., NULL}     }      Any ideas? I can't seem to find any solutions already out there. Also, how can I sort by the first column alphabetically?


Drop selection of columns from a ragged array

I have an application where I need to drop some arbitrary list of columns from a ragged array (where of course the shortest array rows have at least all the specified columns). E.g., given a ragged list:               {{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}, {1, 2, 3, 4, 5}, {1, 2, 3, 4, 5, 6, 7, 8, 9},       {1, 2, 3, 4, 5, 6, 7, 8}}      and a column selection of `{1, 3, 5}`, the resulting array after dropping these is               {2, 4, 6, 7, 8, 9, 10}, {2, 4}, {2, 4, 6, 7, 8, 9}, {2, 4, 6, 7, 8}      The closest I could find searching here was How to use “Drop” function to drop matrix' rows and columns in an arbitrary way?, but that has (nice) solutions for well-formed arrays, while I'm working with ragged arrays of (1000-100000) X (20-2000). I've tried schemes using unique padding to the length of the longest row, operating, then dropping the padding and found that slow. I'm currently using:               colDropper[array_, cols_] := Module[{s = Split[Sort@cols, #2 == #1 + 1 &]},       Fold[Drop[#, {}, #2] &, array, (DeleteDuplicates /@ s[[All, {1, -1}]]) -           Most@Accumulate@Prepend[Length /@ s, 0]]]      which does the job and performs... OK, but there's got to be a way that combines elegance and speed (unfortunately, as with most data I work with, not machine-precision is the usual here so compiling seems out...)


MathLink and C++ vector container

# The Problem. I have a C++ class that does some computations, and returns a C++ vector object (the length of which can possibly vary with each run). I want to store each of these vectors as a list in _Mathematica_ , so, for instance, if three iterations returns the vectors `(0, 1)`, `(0.02, 0.9)` and `(0.04, 0.73)`, I want this output to be written into a _Mathematica_ list of the form `{{0,1},{0.02, 0.9},{0.04, 0.73}}`. # My limitations. This is the first time I am trying to mess with MathLink. Having spent all of today trying to get this to work, I'm feeling pretty lost. The documentation that has shipped with my _Mathematica_ distribution, is helpful only in that I know what to do to write most of the template file. But I can't quite understand how to finish it, and what to do next. # Operating System and other information I am on a Mac running Snow Leopard 10.6.8. _Mathematica_ is installed in the usual place: `/Applications/Mathematica.app` # Code First, what I believe are the relevant portions of the C++ code that I already have               #include<iostream>     #include<vector>     #include<deque>     #include<cmath>     // and a bunch of other files          class mp{               // stuff that defines the class     public:          // some functions     vector <long double> viewCurrent(); // returns the (t, x) vector for the current state of the                                         // system; note that x can be a vector itself          };      What I would like is to store the output of `mp::viewCurrent()` into _Mathematica_ lists. How do I do this?


Circuit drawing in Mathematica

This past semester I taught an introductory electromagnetism course and had quite a nice time using Mathematica to draw all sorts of figures and diagrams (mostly for problems and etc.). However, I was unable to create a nice environment for the basic circuit elements such as resistors, capacitors, etc. A Resistor, for instance, was annoying to draw a single one by hand. But after that, ideally, I would have liked to have a function `Resistor[{p1,p2}]` which functions exactly like the `Line` function but gives a line with a resistor in it (labels are not necessary since they can easily be added latter with the `Text` function). This function could then be readily generalized to a function `CircuitElement[{p1,p2},element]` where "element" stands for any element one has previously drawn. I have had quite some difficulty with these kinds of functions, perhaps due to my lack of knowledge on computational geometry. I think this kind of functionality might be of interest to many people. So, any thoughts or tips on how to get started? * * * Additionally I would like to have output that is similar to the following: ![circuit diagram](http://i.stack.imgur.com/KYB0K.png)


How to use results of NDsolve[] for further solving of ODEs?

I have a system of ODEs with 10 eqns. I can solve the first 5 independently. How can I use those results to solve for the remaining 5? An easy example would be $\dot{x}=f(x), \quad \dot{y}=g(x,y)$ I can solve for x and now I want to use the interpolating function to solve for y. Thanks


FeynRules: Graph problem

Does anyone use the Feynrules Mathematica package? I'd like to know how could I write this vertex explicitly with sum on all indices               ((MD- Me CKM11) /4 vev)  dbar.ProjM. d X       where `X` is scalar particle So I'd like to write some thing like :               ((Md IndexDelta[i,j] - Ml CKM[i,j])/4 vev)( SR dqbar[i].ProjM. dq[j] );      This expression give me errors on FeynRules. so what do you think the right for it?


Numerical solution of Bessel-like equation using NDSolve

I need to calculate solution of Bessel-like equation having general form: $\frac{d^2F}{dr^2}+\frac{1}{r}\frac{dF}{dr}+Q(r)F(r)=0$. Problems come from the points near $r=0$ leading to numeric errors. For example, simple Bessel equation can be solved using DSolve:               DSolve[{y''[x] + 1/x y'[x] + y[x] == 0, y[0] == 1, y'[0] == 0}, y[x], x]      with output:               {{y[x] -> BesselJ[0, x]}}      However same equation using NDSolve produces errors:               sol = NDSolve[{y''[x] + 1/x y'[x] + y[x] == 0, y[0] == 1, y'[0] == 0}, y[x], {x, 0, 10}]          Power::infy: Infinite expression 1/0. encountered. >>     Infinity::indet: Indeterminate expression 0. ComplexInfinity encountered. >>     NDSolve::ndnum: Encountered non-numerical value for a derivative at x == 0.`. >>      The question is: how to overcome erros in NDSolve routine and get numeric solution?


Friday the 13th related tables

This code               Needs["Calendar`"];     days = {Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday};     c = Count[          Flatten[Table[            DayOfWeek[{y, m, 13}], {y, 2000, 2399}, {m, 12}]], #] & /@ days;     TableForm[       { days, c, PaddedForm[#, {6, 4}] & /@ (100. c/Plus @@ c),            ToString //@ Flatten[Position[Sort[c, Greater], #]] & /@ c},              TableDirections -> {Row, Column},                TableHeadings -> {{"day", "numbers of 13s", "percentage", "rank"},                  None}]      will give this table: (counts of 13ths over days of week, using 400 years data) ![enter image description here](http://i.stack.imgur.com/xksZ8.png) _(this is used as an illustration of interesting fact that 13th is more likely to be Friday than any other day of week)_ How can I obtain a table that counts Fridays over days of month (1st, 2nd, ...) also over 400 years?


Hypergeom to Bessel

Is there any way to get Bessel function equivalent to a Hypergeom function. Would it be possible in general ? From maple integration (As discussed in Answer ID 37931), the result of a symbolic integration is                r^4/32 * hypergeometric([1/2],[3/2,3/2,2,2],r^4/64)      Is there any way to represent the above hypergeom function into equivalent BesselJ function. Your inputs are greatly appreciated.


Rayleigh Criterion

I want to use the Rayleigh criterion to find the resolution of an optical system. I have two functions `f1 = Sinc[x]^2` and `f2 = Sinc[x-T]^2`, `T` being the translation. I want to change the value of `T` until the first minimum of `f2` coincides with the maximum of `f1` (Rayleigh criterion). That being achieved, the value `x` and `T` should be returned. Pseudocode: for `x=100` translate `T` till the first min of `f2` coincide with peak of `f1` print `{x, T}` repeat the same procedure for `x=105`...upto `x=200`. so, what i would like to do is basically start the programm and have a table with the values `x` and `T`. Thanks in advance everyone, have a nice one.


Sensitivity Analysis: Global Sensitivity and Screening

I have a model which accepts several input parameters and now I want to study the sensitivity to certain parameters as described in here: Cross Validated Answer and in Wikipedia. There is also a link to Matlab routines. Now I'm looking for something like this for Mathematica but only found something for the SystemModeler. Is there a package or build-in function for   * Global Sensitivity Analysis    * Local Sensitivity Analysis    * Screening (Morris)


How to find Image Size of a control object?

I want to find the `ImageSize` or at least dimensions of any control object irrespective of it being an image or an any other control such as `Button`s,etc. This is my code for button: `button = Button["ew", Null, ImageSize -> {100, 50}]` `ImageDimensions` provides size of images only and not of control objects. So, initially, I rasterized my control object using `Rasterize`. And then displayed the image dimensions. However the image dimensions is not exact value.               rastButton = Rasterize[button, RasterSize -> 100]       bt = Button["ew", Null, {ImageSize -> {100, 50}}]       rastbt = Rasterize[bt, RasterSize -> 100]       ImageSize[rastbt]       ImageDimensions[rastbt]       (*  Out[272] = {100, 52} *)          bt = Button["ew", Null, {ImageSize -> {100, 1}}]     rastbt = Rasterize[bt, RasterSize -> 100]     ImageSize[rastbt]     ImageDimensions[rastbt]     (* Out[272] = {100, 17} *)      I also believe `Rasterize` provides error values when I call `Rasterize[button][[2, 2]]`. Is this a bug? Is there any workaround to estimate the size of control objects? Ultimately, the purpose of estimating the size is to place the control object very accurately in a grid layout within specified co ordinates.


Having Trouble Solving this System of ODEs

I am having trouble finding any solution to this ODE:               ρ = 1.225;     b = 47.5;     Sw = 290;     AR = b^2/Sw;     m = 176000; g=9.81; W=m*g;          Lclimb = 1/2 ρ*(Vclimb[t])^2*Sw*CLfun;     Dclimb = 1/2 ρ*(Vclimb[t])^2*Sw (f/Sw + CLfun^2/(π*e*AR));     Tclimb = 2*(At*(Vclimb[t])^2 + Bt*Vclimb[t] + Ct);     Eqn1 = (Tclimb - Dclimb - W*Sin[θ[t]])/m == D[Vclimb[t], t];     Eqn2 = (Lclimb - W*Cos[θ[t]])/(m*Vclimb[t]) == D[θ[t], t];     DSolve[{Eqn1, Eqn2, Vclimb[0]==75, θ[0]==3 Degree}, {Vclimb, θ}, t]      I would be fine with NDSolve too, I just can't get this to evaluate to anything and want to know if I am doing anything wrong syntax wise or in my method.


Faster way to perform SameQ[Reduce[...], Reduce[...]]

I'm have some expressions that I need to confirm the equality of. `SameQ[Reduce[...], Reduce[...]]` works like a charm for the more simple expressions, however when they get much more complicated than the ones below Mathematica takes an inordinately large period of time, memory and CPU power to return an answer.               SameQ[         Reduce[(a > b && a > c && a > d && a > e && a > f && a > g && a <= h) || (a <= b && b > c && b > d && b > e && b > f && b > g && b <= h) || (a <= c && c >= b && c > d && c > e && c > f && c > g && c <= h) || (a <= d && d >= b && d >= c && d > e && d > f && d > g && d <= h) || (a <= e && e >= b && e >= c && e >= d && e > f && e > g && e <= h) || (a <= f && f >= b && f >= c && f >= d && f >= e && f > g && f <= h) || (a <= g && g >= b && g >= c && g >= d && g >= e && g >= f && g <= h), {a,b,c,d,e,f,g,h}, Reals],         Reduce[(a <= h && b <= h && c <= h && d <= h && e <= h && f <= h && g <= h), {a,b,c,d,e,f,g,h}, Reals]     ]      Can I rephrase this query to Mathematica that would enable it to run any quicker?


Is it possible to specify a context-sensitive, "depth-agnostic" rewrite rule?

I'm using the term "depth-agnostic" in this post to describe structural patterns featuring a "target" sub-pattern that can occur "at any depth" relative to one or more "context" sub-patterns. As a simple example of a "depth-agnostic" pattern, consider the following rewrite rule: > RR1 > > replace with the expression `WRAP[X]` any expression `X_TGT` contained > _somewhere_ within some expression `_CTX`.1 Here the target and context sub-patterns are `X_TGT` and `_CTX`, respectively. The depth-agnostic bit comes in as the phrase " _somewhere_ within". In other words, RR1 says to find expressions that look like               … CTX[ … y0[ … y1[ … … yk[ … TGT[ … ] … ] … … ] … ] … ] …      ...(where the number of nested subexpressions `y0`, `y1`, ..., `yk` is indeterminate), and rewrite them as               … CTX[ … y0[ … y1[ … … yk[ … WRAP[TGT[ … ]] … ] … … ] … ] … ] …      Thus, if we defined               ping = foo[{1, CTX[bar[2,  3, {TGT[0], 4} ]]}];     ding = foo[{1, CTX[bar[2, {3, {TGT[0], 4}}]]}];     pong = foo[{1, baz[bar[2,  3, {TGT[0], 4} ]]}];      then, according to RR1, `ping` would be changed to               foo[{1, CTX[bar[2,  3, {WRAP[TGT[0]], 4} ]]}]      ...and `ding` would be changed to               foo[{1, CTX[bar[2, {3, {WRAP[TGT[0]], 4}}]]}]      On the other hand, `pong` would be unaffected by RR1, even though it contains an expression `_TGT`, because this expression does not occur " _somewhere_ within an expression `_CTX`". The problem is > how to implement a rewrite rule that features such a "depth-agnostic" > pattern in _Mathematica_? To see why "depth-agnosticity" is an issue, consider rewrite rule RR2 below, identical in every way to RR1, except that it specifies a single, unambiguous depth for the target relative to the context sub-pattern (IOW, it is not "depth-agnostic"): > RR2 > > replace with the expression `WRAP[X]` any expression `X_TGT` contained _at a > depth of 3 within_ some expression `_CTX`. As shown below, implementing RR2 in _Mathematica_ is straightforward (though, admittedly, a bit tedious), but unfortunately, it is nowhere as general as RR1 (e.g. RR2 affects only `ping`, not `ding`). Here's one (rather uninspired) implementation of RR2 in action:               {ping, ding, pong} /.       CTX[a1___, h1_[a2___, h2_[a3___, X_TGT, z3___], z2___], z1___] ->        CTX[a1, h1[a2, h2[a3, WRAP[X], z3], z2], z1] // TableForm          foo[{1, CTX[bar[2, 3, {WRAP[TGT[0]], 4}]]}]     foo[{1, CTX[bar[2, {3, {TGT[0], 4}}]]}]     foo[{1, baz[bar[2, 3, {TGT[0], 4}]]}]      This implementation fulfills the earlier assertions about RR2: it like RR1 with respect to `ping` (affects it) and `pong` (does not affect it), but not with respect to `ding` (RR1 affects `ding` but RR2 doesn't). * * * There are at least two important generalizations of the ideas described above. The first one is the situation in which there are multiple context sub- patterns that are themselves at indeterminate depths relative to each other. For example: > RR3 > > replace with the expression `WRAP[X]` any expression `X_TGT` and being > contained _somewhere_ within some expression `_CTX` that is itself contained > _somewhere_ within some expression `_List`. The second generalization could be expressed as allowing "negative depths", or in other words, patterns in which the context sub-pattern is contained within the target subpattern. For example: > RR4 > > replace with the expression `WRAP[X]` any expression `X_TGT` containing > _somewhere_ within it some expression `_CTX`. * * * 1In this post I will resort to Mathematica's notation for patterns. Namely, `_H` denotes a pattern matching any expression having head `H`, and `X_H` denotes a pattern matching any expression (henceforth referred to as `X`) having head `H`. I will abuse this notation slightly, writing "an expression `_H`" as shorthand for "an expression matching the pattern `_H`", and "an expression `X_H`" as shorthand for "an expression (henceforth referred to as `X`) matching the pattern `_H`.)


Enlarge an image and increase its resolution

An ongoing purely recreational project. I got my introduction to image processing with this Rotating perspective... question and had a lot of fun with it. Now I want to take it to the next step. The great solutions to the earlier question led me to the following image as quite a small JPEG: ![collage](http://i.stack.imgur.com/oPQMH.jpg) Now, I hope to create a poster of the image that I can have printed at say 4' horizontally. To do this I need a JPEG which will have at least a 4' horizontal dimension with a resolution of at least 300 dpi. The artist created the original collage from pieces of cut colored paper - each piece a completely saturated color. The entire collage only has 10 or 11 colors. I can pretty easily identify RGB values for each. Also, the shapes that look approximately rectangular should all show as actual rectangles. The artist originally used full sheets of the colored paper. If you copy the above image into _Mathematica_ and zoom in on it even a little like this: ![zoom of collage](http://i.stack.imgur.com/YzHof.png) you'll see that it doesn't have crisp straight edges and many of the colors appear modulated rather than saturated. This will only get worse the more one blows up the image. To enlarge this up to 4' wide I need a way to address all of those issues. Call the attached JPEG `i = Import["http://i.stack.imgur.com/oPQMH.jpg"];`               ImageResize[i, 5000]      gets me pretty close to the size I need.               ColorQuantize[i, 11]      ![collage2](http://i.stack.imgur.com/Vh6jO.jpg) begins to get me towards the saturation of color that I want. But these approaches don't get me all the way. Do I need to try point operations and/or transformations of some kind? Do I need to breakout grey scales for each of the RGB values? Would some kind of mask help? Something so I break the problem down into smaller pieces. Any guidance appreciated. * * * P.S., I have the original artist's full cooperation and permission in this little project. If anyone wants to make a print of the final product and display it he'd love to see it out in the world and enjoyed.


How to fill a whole rectangle with text?

I have a rectangle with specified dimensions and I'd like to fill it with text, so that the text uses all (well, as much as possible) of the available area. I tried to do it with               Framed@Pane[       TextCell[ExampleData[{"Text", "LoremIpsum"}],        TextJustification -> 0, TextAlignment -> Center, ImageMargins -> 0],        ImageSize -> 1/2 {1920, 1080}, ImageSizeAction -> "ResizeToFit",        Alignment -> {Center, Center}]      I'm not concerned about the little gaps caused by the `TextJustification` option, but `ImageSizeAction -> "ResizeToFit"` bothers me because it leaves empty spaces at the top and bottom of the rectangle. This becomes more apparent when the rectangle size gets bigger, and I want to make some very large images. Rectangle size 960x540: ![small rectangle](http://i.stack.imgur.com/9zlHy.png) Rectangle size 1920x1080: ![bigger rectangle](http://i.stack.imgur.com/MfcfU.png) I would expect that the font size would increase to fill the empty space, but this does not happen.


How to inherit options by scoping?

Consider the following example: you have a function `framed` producing a cell with a button that, when pushed, calls `framed` again. How to supply options to `framed` such that whenever the button is pushed, the "embedded" `framed` inherits these options? If, however, the `framed` is called **not** by the button, it should use the default options (as it cannot inherit it from a parent). The following example works as expected (any new cell will inherit `a -> 1111`:               Options[framed] = {a -> 1};     Options[button] = {"framedOptions" -> Options@framed};     button[x_, opts : OptionsPattern[]] :=        Button[x, Print@framed[x, OptionValue@"framedOptions"]];     framed[x_, opts : OptionsPattern[]] :=        Framed[{button[x, "framedOptions" -> Flatten@{opts}], OptionValue@a}];          Print@framed["Push", a -> 1111];      Pushing the displayed button yields a second cell with inherited options: ![Mathematica graphics](http://i.stack.imgur.com/x7N1x.png) But for certain reasons I want to avoid unnecessary options like `"framedOptions"` and use some kind of scoping as there could be multiple embeddings and recursion and I don't want to forward `"framedOptions"` all the time. No scoping would work however, as the button funcion is only evaluated at runtime.               Options[framed] = {a -> 1};     button[x_] := Button[x, Print@framed@x];     framed[x_, opts : OptionsPattern[]] := Framed[        Internal`InheritedBlock[{framed = framed},         SetOptions[framed, Flatten@{opts}];         {button@x, OptionValue@a}         ]];          Print@framed["Push", a -> 1111];      ![Mathematica graphics](http://i.stack.imgur.com/RanqH.png) Note that the problem extends to attributes or any part of a function definition. What I would really need is an `InheritedDynamicBlock` (nonexistent) that not justs inherits the function definition but also keeps it local to a _certain part of the screen_ (where the original content is displayed). Any idea?


How can you convert a matrix back into a list of lists?

It is very simple in Mathematica to convert a list of lists into a matrix: all you need to do is apply the `//MatrixForm` function to it and voila. Is it possible to do the reverse though? I have a matrix that I want to convert back into a list of lists, so as to manipulate its elements more easily. Is this possible? Is there a '`ListForm`' function that deletes all `MatrixForm`s from the element in question? As an example, here is the `FullForm` for one of my elements: `MatrixForm[List[List[63],List[4,62]]]` Is there a function which would take this as input and return simply `List[List[63],List[4,62]]`? Thank you


FoldWhile and FoldWhileList

Mathematica has had `NestWhile` and `NestWhileList` for some time. But, to date, it has not implemented a built-in `FoldWhile` or a `FoldWhileList`. So, since these constructs seem useful to me, I have tried to brew my own. Here are my current implementations. Anyone have suggestions on how either of these might be improved. I'd be particularly interested in a variant of `FoldWhile` that did not require as much memory as `FoldWhileList`.                FoldWhileList[f_, init_, list_, test_, m_, max_] :=       Block[{i = 0},          NestWhileList[(i = i + 1; f[#, Part[list, i]]) &, init, test, m, max]]      and                FoldWhile[f_, init_, list_, test_, m_, max_] :=          Last[FoldWhileList[f, init, list, test, m, max]]


How to solve equations over polynomial rings

sorry if my question is very basic but I don't know what to even search to look it up and the only "obvious" places I thought of had nothing. Some background, for whatever context it might provide. I'm working with a certain ring of functions $R=\langle P_i\rangle$, where $P_i=ax^i+y^i+z^i+(-1)^i (ax+y+z)^i\in\mathbb{C}(a)[x,y,z]$ (i.e. I normally think of $a$ as a coefficient of $x$, but here I'm actually keeping it as a variable, hoping to generalize a calculation I'll explain below). By a theorem of Hilbert's, I know that $R$ is finitely generated. More importantly, if it is free over $\mathbb{C}[P_2, P_3, P_4]$, it is Cohen-Macaulay and that's what I want to know ultimately. If I compute the Hilbert series and all coefficients are positive, then this tells me where I should pick generators from. Sorry if this is more information than is relevant. OK, well in particular, say I think the generators should be $1, P_4, P_5$, meaning that polynomials like $P_{10}$ should have a (unique) expression of the form $f_1(P_2, P_3, P_4)+f_2(P_2, P_3, P_4)P_4+f_3(P_2, P_3, P_4)P_5=P_{10}$, where the $f_i$ are polynomials. I don't care to show the uniqueness, but given all the $P_i$, is there any systematic way to have Mathematica solve for the polynomials $f_i$? The bounds on degrees give some pretty tight bounds on the degrees of the $f_i$. Any help would be much appreciated!


Apply IC and BCs on Second - Order Linear PDE

I am now trying to solve second - order linear partial differential equation in that interested eq. has been separated into variables to simplify the procedure for Mathematica. Here is my equation; ![Differential Equation](http://i.stack.imgur.com/mHre8.jpg) or separated form, ![Separated Form](http://i.stack.imgur.com/yZGBZ.jpg) Also, the last equation is coded in Mathematica as;                   L[t_, z_] := T[t] Z[z]         Eq = (D[T[t], t]/(A*T[t])) == R*(D[D[Z[z], z], z]/Z[z]) - B*(D[Z[z], z]/Z[z])         L[t, z] /. Flatten@{DSolve[Eq[[1]] == F, T, t, GeneratedParameters -> CT],          DSolve[Eq[[2]] == F, Z, z, GeneratedParameters -> CS]}      Then, the solution is given as; ![The Solution](http://i.stack.imgur.com/aKpzb.jpg) However at that point, I should plug IC and BCs into related eq. to both get rid of constants and proceed with my calculations. These are my IC and BCs, respectively; ![IC](http://i.stack.imgur.com/BtfzA.jpg) ![BC1](http://i.stack.imgur.com/fQpUT.jpg) ![BC2](http://i.stack.imgur.com/cRGa0.jpg) How can I solve this problem? Is there any way to insert these IC and BCs into the code above? or Does there exist any method, command etc. to come up with solution without integration constants? Note: Any of the values included in BCs is neither a function of z nor that of t.


How can I wrap text around a circle?

How can I wrap text around a circle? For example: the text in the sectors of this chord plot. Perhaps one could use `FilledCurve[]` and then apply a `GeometricTransformation[]`?