I am trying to find the minimum of a function. What I am working on is something like
FindMinimum[Norm[{u1, u2, u3}, 2] + Norm[{v1, v2, v3}, 2] + Norm[{p1, p2, p3}, 2], {u1, 0, 1}, {u2, 0, 1}, {u3, 0, 1}, {v1, 0, 1}, {v2, 0, 1}, {v3, 0, 1}, {p1, 0, 1}, {p2, 0, 1}, {p3, 0, 1}]
Now I want add the constraints:
{u1, u2, u3} + {v1, v2, v3} + {p1, p2, p3} = {somevec1, somevec2, somevec3}
and I want each of the 3 vectors to have at least 1 zero, and this is giving me trouble.
I tried Count[{u1, u2, u3}, 0] > 1 and I'm getting this error
FindMinimum::eqineq: Constraints in {False} are not all equality or inequality constraints. With the exception of integer domain constraints for linear programming, domain constraints or constraints with Unequal (!=) are not supported. >>
Edit:
The current thing I have is:
w = {1, 1, 1};
FindMinimum[{Norm[{u1, u2, u3}, 2] + Norm[{v1, v2, v3}, 2] + Norm[{p1, p2, p3}, 2], {u1, u2, u3} + {v1, v2, v3} + {p1, p2, p3} == w && u3 == 0 && v1 == 0 && p2 == 0}, {u1, 0, 1}, {u2, 0, 1}, {u3, 0, 1}, {v1, 0, 1}, {v2, 0, 1}, {v3, 0, 1}, {p1, 0, 1}, {p2, 0, 1}, {p3, 0, 1}]
which is not general enough.
How about u1*u2*u3=0, ... etc.
Related
I used the following to graph my two functions:
p1 = Plot[100 t^2*Sin[Sqrt[t]], {t, 0, 7}, AxesOrigin -> {0, 5000}]
p2 = Plot[Piecewise[{{250, 0 <= t < 3}, {2000, 3 < t <= 7}}], {t, 0, 7},
AxesOrigin -> {0, 5000}]
I can not figure out how to find the intersection of the graph, please help.
Using FindRoot with initial guesses observed from the plots.
sol = FindRoot[100 t^2*Sin[Sqrt[t]] == 250, {t, 2}];
t1 = t /. sol
1.61743
sol = FindRoot[100 t^2*Sin[Sqrt[t]] == 2000, {t, 5}];
t2 = t /. sol
5.07622
y = With[{t = 3}, 100 t^2*Sin[Sqrt[t]]];
p1 = Plot[100 t^2*Sin[Sqrt[t]], {t, 0, 7}, AxesOrigin -> {0, 5000}];
p2 = Plot[Piecewise[{{250, 0 <= t < 3}, {2000, 3 < t <= 7}}], {t, 0, 7},
AxesOrigin -> {0, 5000}, Exclusions -> None];
Show[p1, p2, ListPlot[{{t1, 250}, {t2, 2000}, {3, y}},
PlotStyle -> PointSize[0.03]]]
Ok! I'm working towards building a nested manipulate command that will solve n number of damped oscillating masses in series (with fixed endpoints). I have everything pretty much working but I have one problem - when I increase the number of oscillators, my initial conditions lag behind a bit. For example, if I set n to 4, Mathematica says I still only have 2 initial conditions (the starting number - position and velocity for one oscillator). When I then move to 3, I now have 8 (from my 4 oscillators) - which is too many for the state space equations, and it all fails. What is going on?
(Yes, I know that my initial conditions aren't going to be put in correctly yet, I'm just trying to get them to match up first).
coupledSMD[n_, m_, k_, b_, f_, x0_, v0_, tmax_] :=
Module[{aM, bM, cM, dM},
aM = Join[Table[Boole[i == j - n], {i, n}, {j, 2 n}],
Join[
If[n != 1,DiagonalMatrix[-2 k/m Table[1, {n}]] +
k/m DiagonalMatrix[Table[1, {n - 1}], 1] +
k/m DiagonalMatrix[Table[1, {n - 1}], -1],
{{-2 k/m}}],
If[n != 1,DiagonalMatrix[-2 b/m Table[1, {n}]] +
b/m DiagonalMatrix[Table[1, {n - 1}], 1] +
b/m DiagonalMatrix[Table[1, {n - 1}], -1],
{{-2 b/m}}], 2]];
bM = Join[Table[0, {n}, {1}], Table[1/m, {n}, {1}]];
cM = Table[Boole[i == j], {i, n}, {j, 2 n}];
dM = Table[0, {n}, {1}];
OutputResponse[
{StateSpaceModel[{aM, bM, cM, dM}], Flatten[Join[x0, v0]]},
f, {t, 0, tmax}]
]
Manipulate[
With[{
x0s = Table[Subscript[x, i, 0], {i, 1, n}],
v0s = Table[Subscript[v, i, 0], {i, 1, n}],
initialx = Sequence ## Table[{{Subscript[x, i, 0], 0}, -10, 10}, {i, 1, n}],
initialv = Sequence ## Table[{{Subscript[v, i, 0], 0}, -10, 10}, {i, 1, n}]},
Manipulate[
myplot = coupledSMD[n, m, k, b, f, x0s, v0s, tmax];
Plot[myplot, {t, 0, tmax}, PlotRange -> yheight {-1, 1},
PlotLegends -> Table[Subscript[x, i, 0], {i, 1, n}]],
Style["Initial Positions", Bold],
initialx,
Delimiter,
Style["Initial Velocities", Bold],
initialv,
Delimiter,
Style["System conditions", Bold],
{{m, 1, "Mass(kg)"}, 0.1, 10, Appearance -> "Labeled"},
{{k, 1, "Spring Constant(N/m)"}, 0.1, 10, Appearance -> "Labeled"},
{{b, 0, "Damping Coefficient(N.s/m)"}, 0, 1, Appearance -> "Labeled"},
{{f, 0, "Applied Force"}, 0, 10, Appearance -> "Labeled"},
Delimiter,
Style["Plot Ranges", Bold],
{tmax, 10, 100},
{{yheight, 10}, 1, 100},
Delimiter,
ControlPlacement -> Flatten[{Table[Right, {2 n + 2}], Table[Left, {8}]}]
]],
{n, 1, 4, 1}
]
Edit: Updated the code. It works now, but I'm still getting the errors. I'm guessing that it has something to do with a time lag in the updating process? - That some parts are getting updated before others. Again, it seems to be working perfectly, except it throws these errors (the errors seem superfluous to me, as if they are remnants in the code, but not actually causing a problem)
But I don't really know what I'm talking about :)
I want to generate a plot like the following
I am not sure how to generate a shading even though I can get the frame done. I'd like to know the general approach to shade certain areas in a plot in Mathematica. Please help. Thank you.
Perhaps you are looking for RegionPlot?
RegionPlot[(-1 + x)^2 + (-1 + y)^2 < 1 &&
x^2 + (-1 + y)^2 < 1 && (-1 + x)^2 + y^2 < 1 && x^2 + y^2 < 1,
{x, 0, 1}, {y, 0, 1}]
Note the use of op_ in the following (only one set of equations for the curves and the intersection!):
t[op_] :=Reduce[op[(x - #[[1]])^2 + (y - #[[2]])^2, 1], y] & /# Tuples[{0, 1}, 2]
tx = Texture[Binarize#RandomImage[NormalDistribution[1, .005], 1000 {1, 1}]];
Show[{
Plot[y /. ToRules /# #, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}] &# t[Equal],
RegionPlot[And ## #, {x, 0, 1}, {y, 0, 1}, PlotStyle -> tx] &# t[Less]},
Frame->True,AspectRatio->1,FrameStyle->Directive[Blue, Thick],FrameTicks->None]
If, for any particular reason, you want the dotted effect in your picture, you can achieve this like so:
pts = RandomReal[{0, 1}, {10000, 2}];
pts = Select[pts,
And ## Table[Norm[# - p] < 1, {p,
{{0, 0}, {1, 0}, {1, 1}, {0, 1}}}] &];
Graphics[{Thick,
Line[{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}],
Circle[{0, 0}, 1, {0, Pi/2}],
Circle[{1, 0}, 1, {Pi/2, Pi}],
Circle[{1, 1}, 1, {Pi, 3 Pi/2}],
Circle[{0, 1}, 1, {3 Pi/2, 2 Pi}],
PointSize[Small], Point[pts]
}]
I have a problem similar to IntegerPartitions function, in that I want to list all non-negative integer xi's such that, for a given list of integers {c1,c2,...,cn} and an integer n:
x1*c1+x2*c2+...+xn*cn=n
Please share your thoughts. Many thanks.
The built-in function FrobeniusSolve solves the case where the c1, c2, ..., cn are positive integers (and the right hand side is not n):
In[1]:= FrobeniusSolve[{2, 3, 5, 6}, 13]
Out[1]= {{0, 1, 2, 0}, {1, 0, 1, 1}, {1, 2, 1, 0}, {2, 1, 0, 1}, {2,
3, 0, 0}, {4, 0, 1, 0}, {5, 1, 0, 0}}
Is this the case you need, or do you need negative c1, c2, ..., cn also?
Construct your list of ci's and coefficients using
n = 10;
cList = RandomInteger[{1, 20}, n]
xList = Table[Symbol["x" <> ToString[i]], {i, n}]
Then, if there's a set of solutions for non-negative xi's, it will be found by
Reduce[cList.xList == n && And##Thread[xList >= 0], xList, Integers]
i'd like to have something like this
w[w1_] :=
NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0}, y, {x, 0, 30}]
this seems like it works better but i think i'm missing smtn
w := NDSolve[{y''[x] + y[x] == 2, y[0] == w1, y'[0] == 0},
y, {x, 0, 30}]
w2 = Table[y[x] /. w, {w1, 0.0, 1.0, 0.5}]
because when i try to make a table, it doesn't work:
Table[Evaluate[y[x] /. w2], {x, 10, 30, 10}]
i get an error:
ReplaceAll::reps: {<<1>>[x]} is neither a list of replacement rules nor a valid dispatch table, and so cannot be used for replacing. >>
ps: is there a better place to ask questions like that? mathematica doesn't have supported forums and only has mathGroup e-mail list. it would be nice if stackoverflow would have more specific mathematica tags like simplify, ndsolve, plot manipulation
There are a lot of ways to do that. One is:
w[w1_] := NDSolve[{y''[x] + y[x] == 2,
y'[0] == 0}, y[0] == w1,
y[x], {x, 0, 30}];
Table[Table[{w1,x,y[x] /. w[w1]}, {w1, 0., 1.0, 0.5}]/. x -> u, {u, 10, 30, 10}]
Output:
{{{0., 10, {3.67814}}, {0.5, 10, {3.25861}}, {1.,10, {2.83907}}},
{{0., 20, {1.18384}}, {0.5, 20, {1.38788}}, {1.,20, {1.59192}}},
{{0., 30, {1.6915}}, {0.5, 30, {1.76862}}, {1.,30, {1.84575}}}}
I see you already chose an answer, but I want to toss this solution for families of linear equations up. Specifically, this is to model a slight variation on Lotka-Volterra.
(*Put everything in a module to scope x and y correctly.*)
Module[{x, y},
(*Build a function to wrap NDSolve, and pass it
the initial conditions and range.*)
soln[iCond_, tRange_, scenario_] :=
NDSolve[{
x'[t] == -scenario[[1]] x[t] + scenario[[2]] x[t]*y[t],
y'[t] == (scenario[[3]] - scenario[[4]]*y[t]) -
scenario[[5]] x[t]*y[t],
x[0] == iCond[[1]],
y[0] == iCond[[2]]
},
{x[t], y[t]},
{t, tRange[[1]], tRange[[2]]}
];
(*Build a plot generator*)
GeneratePlot[{iCond_, tRange_, scen_,
window_}] :=
(*Find a way to catch errors and perturb iCond*)
ParametricPlot[
Evaluate[{x[t], y[t]} /. soln[iCond, tRange, scen]],
{t, tRange[[1]], tRange[[2]]},
PlotRange -> window,
PlotStyle -> Thin, LabelStyle -> Medium
];
(*Call the plot generator with different starting conditions*)
graph[scenario_, tRange_, window_, points_] :=
{plots = {};
istep = (window[[1, 2]] - window[[1, 1]])/(points[[1]]+1);
jstep = (window[[2, 2]] - window[[2, 1]])/(points[[2]]+1);
Do[Do[
AppendTo[plots, {{i, j}, tRange, scenario, window}]
, {j, window[[2, 1]] + jstep, window[[2, 2]] - jstep, jstep}
], {i, window[[1, 1]] + istep, window[[1, 2]] - istep, istep}];
Map[GeneratePlot, plots]
}
]
]
We can then use Animate (or table, but animate is awesome)
tRange = {0, 4};
window = {{0, 8}, {0, 6}};
points = {5, 5}
Animate[Show[graph[{3, 1, 8, 2, 0.5},
{0, t}, window, points]], {t, 0.01, 5},
AnimationRunning -> False]