Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Mathematics sorted by activeHow to compute the following by using command N[ ]?
https://community.wolfram.com/groups/-/m/t/1615026
![N[ ] command][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-02-17at7.19.22PM.png&userId=1615003
How to express the answer in scientific notation?Laura Figueroa2019-02-18T00:22:24ZHelp me please! DSolveValue::overdet
https://community.wolfram.com/groups/-/m/t/1614780
DSolveValue[{y''[x] - x y'[x] + (y[x])^2 == x, y[1] == 1, y'[x] == 0},
y[x], x]
DSolveValue::overdet: There are fewer dependent variables than equations, so the system is overdetermined
What I should do?anna sent2019-02-17T19:48:56ZAmazing comparison (700+ pages!) of PDE solving. There's a gap to be filled
https://community.wolfram.com/groups/-/m/t/1610701
On February 11, Nasser M. Abbasi compiled a [huge report][1] about PDE solving with
[Mathematica 11.3 and a recent (2018 version) of another major CAS system][2] , listing some of the PDE textbooks consulted (strangely no one among Evans, Farlow, Strauss, Sauvigny, Taylor is included).
According to the [results][3] and to the [table of results][4] ,
Mathematica is dramaticaly behind its competitor and the knowledge of PDE by both the system seem very limited, compared to results one can find in a textbook.
To be noticed, if you look at his [page][5] , Abbasi seems to use more Mathematica than the competitor.
Let's hope that researchers at Wolfram will implement a **better knowledge of PDE into Mathematica**, rather than spreading their efforts on all those (some of them kind of bizarre) fields : not just to fill the gap with its competitor, but **because PDE is a very crucial MATHEMATICAL topic**.
[1]: https://www.12000.org/my_notes/pde_in_CAS/pde_in_cas_legal.pdf
[2]: https://www.12000.org/my_notes/pde_in_CAS/pdse1.htm
[3]: https://www.12000.org/my_notes/pde_in_CAS/pdse2.htm
[4]: https://www.12000.org/my_notes/pde_in_CAS/pdse3.htm
[5]: https://www.12000.org/index.htmCamila Garcia2019-02-11T19:48:19ZModel a wave equation forced oscillation, A(t)?
https://community.wolfram.com/groups/-/m/t/1613702
Tenenbaum, 28D, p339. Forced undamped oscillation.
y[t]''+w0^2 y[t]==F Sin[w1 t+b]
yc==c1 Sin[w0 t+d]
yp==F/(w0^2-w1^2) Sin[w1+b]
(*constants w0,w1,b,d,c1*)
I am told |c|+|F...| is Amplitude(max) (and note is a constant), so that if w0 is near w1, I am told A will be infinite within (one) period. (serway 3rd phy), showing same, says: "due to limitations it will not actually grow infinite"
I am then told (tenenbaum): "if w0 and w1 are equal" (the undet. coeff. solves differently, which i confirmed by doing)
yp==-t F/(2 w0) Cos[w0+b]
Which grows infinite over unbounded t (and no doubt has phy limitations) and A==A(t).
My question is how can minute differences in w0-w1 yield large Amplitude than equality of w0==w1 can (and at that, in a far shorter time). I suspect my "reasoning" here is simply mislead?
My 2nd question is if there are youtube videos or URL showing actual pertinent experiment (or data, but not calculated data) proving the case that small differences are infinitely more powerful than equality - assuming I'm wrong.
I understand F Sin[w0 t+b] (with a w0) may constitute an impossible machine but if is I don't understand it's use in the books. I don't understand the result of a this "machine" causing a wave to be infinite in one period while it has the same frequency unless the problem is ... malformed in practice (a silly machine). If i'm wrong here and machines just such as this are (with limitation) common in electronics, please say so. The use in the books introduce it as a simple equation physically bound, not as any kind of mathematical (unlikely) machine. Which is confusing.
I think I've just read something wrong or am inexperience with electronics scope results. Which is why I ask.John Hendrickson2019-02-15T00:16:44ZMathematica kernel crashing after repeated use of NMinimize
https://community.wolfram.com/groups/-/m/t/1608237
I have quite an complicated function involving NIntegrate and special functions (see the attached file if interested in details) and I would like to minimize it with respect to 6 parameters. When I call NMinimize once, I get a result in about 3 minutes. However, I need to minimize the function for a set of parameters and whenever I try to call similar NMinimize procedure repeatedly, Mathematica kernel crashes without any specific warning message (I get sometimes warning messages regarding convergence of NIntegrate during the calculation, however, these are not correlated with the crashes).
I was trying first varying the parameters with Do cycles. I was told that there might be some memory issues, so I tried to add ClearSystemCache[] to each repetition, however, this did not help. I was also told that Mathematica is better suited for working with lists than with cycles, so I tried to put the different parameter choices into a Table, however, Mathematica crashed again.
I am using Mathematica 11.3 on my laptop and I also tried to run the code on a server with Mathematica 10.3 installed, there was no significant difference.
Doesn't anyone have an idea how to avoid these problems so that I could let Mathematica run the code repeatedly for a longer time?Helena Kolesova2019-02-08T09:37:45ZSome info about the differential equation of LegendreP with respect to x.
https://community.wolfram.com/groups/-/m/t/1613917
Hello, members of Mathematica community.
I would like to ask you about the method which Mathematica uses to find the roots of differential equation of LegendreP with respect to x.
dLegendreP/dx=0 .
Also how big of standard error ( or relative error) does this method give for the roots of dP/dx=0.Rasim Bekir2019-02-15T11:07:12ZStreamPlot the following gradient?
https://community.wolfram.com/groups/-/m/t/1610629
Hello,
it could be, that plenty of people asked this question already. I didn't search the right way. Sorry!
My Problem is with very basic usage of Mathematica:
First I define my new Function:
myFunction[x_, y_] := x^2 - x^4
then I define the gradient of this function as a function:
myGradient[x_, y_] := Grad[myFunction[x, y], {x, y}]
When I want to `StreamPlot[myGradient[x,y], {x, -2, 2}, {y, -2, 2}]` I got an empty diagram. When I use the output of the second last command (myGradient...) the Plotting works fine (`StreamPlot[%6, {x, -2, 2}, {y, -2, 2}]`).
Why does it not work like this and how do I do it right? In general I want to use the output of some input as the value of a function.
Thanks!Julian SSS2019-02-11T19:50:47ZGenerate a table from Solve or NSolve and plot it?
https://community.wolfram.com/groups/-/m/t/1609677
I have a simple question. I want to generate a list. To make things simple, I use a simple model.
xt = Table[{NSolve[x^2 - .001 i == 0 && x > 0]}, {i, 8}];
This generates a table, but when I inquire the value of xt, I got an answer like
xt[[4]]
Answer is
{{{x -> 0.0632456}}}
How can I ListPlot xt?
If I want to ListPlot xt versus another table, how can I do it?
Much thanks to anyone who can tell me.Hong-Yee Chiu2019-02-10T17:55:58ZFind shaded area between two arcs
https://community.wolfram.com/groups/-/m/t/1613233
###Please download the notebook at the end of the discussion
----------
![question][1]
This is a problem posted by a TikTok user. The origional version is for middle school students, so it is safe to assume the two arcs in the problem are from two separated circles. They are tangent to each other at the left top corner of the given rectangle.
Let's extend this problem to a more general case if the longer arc is part of conic section. We can give the coordinates to some points in the picture: $(0,0)$, $(2,0)$,$(4,0)$,$(6,0)$, where the origin is at the left bottom corner.
Clear["Global`*"]
longArc[x_, y_] := x^2/a^2 + (y + h)^2/(h + 4)^2
`longArc` is the implicit form of an ellipse of which the two axes are parallel to x and y axis respectively. The center of the ellipse is said to move downward along the y axis. So the coordinate of the center of ellipse is $(0, -h)$. The semi minor axis in y direction is $b = h+4$. We denote `a` for the semi-major axis. Solve for `a` in terms of `h`:
Reduce[36/a^2+h^2/(4+h)^2==1&&h>0&&a>0,{a}]
we have
h>0&&a==(3 Sqrt[(16+8 h+h^2)/(2+h)])/Sqrt[2]
Now we can define eccentricity of the ellipse as
ecc[h_]:=With[{a=(3 Sqrt[(16+8 h+h^2)/(2+h)])/Sqrt[2]},Sqrt@Abs[a^2-(h+4)^2]/Max[a,h+4]]
in case there is a switch. Use `Manipulate` function to verify the set of valid ellipses:
Manipulate[
a = (3 Sqrt[(16 + 8 h + h^2)/(2 + h)])/Sqrt[2];
GraphicsRow@{ContourPlot[{x^2/a^2 + (y + h)^2/(h + 4)^2 == 1,
x^2 + y^2 == 16}, {x, -10, 10}, {y, -10, 10},
Epilog -> {Point[{6, 0}], Line[{{0, 4}, {6, 4}, {6, 0}}]},
Axes -> True],
Plot[ecc[t], {t, 0, 8}, PlotLabel -> "Eccentricity",
Epilog -> {PointSize[0.03], Point[{h, ecc[h]}]}]
}, {h, 0, 8}]
![ecc][2]
Note that if the eccentrity is zero (downward cusp), we have the a circle that is to be found in the original question.
##Discussion
- If `h` is negative, as the center of ellipse move upward, the ellipse will intersect with the vertical line on the right twice:
![moveup][3]
- If `h` approaches positive infinite, as the ellipse is stretched very long downward, there exists a limit:
![movedown][4]
Because `h` is very large, the eccentricity is very close to 1 according to the graph on the right side. Thus the limit of the streched ellipse is a parabola, with vertex at $(4,0)$ and facing downward. The closed form expression is:
y - 4 = -1/9 x^2
![limit][5]
Use the following plot function in the `Manipulate` function above to see the animation with three curves in one plot:
ContourPlot[
{
x^2/a^2 + (y + h)^2/(h + 4)^2 == 1,
x^2 + y^2 == 16,
9*(y - 4) == -x^2
}, {x, -10, 10}, {y, -10, 10}...]
##Find Numeric Area
`ImplicitRegion` is used in a very straight forward manner. Given `h` is 4:
Module[{h=4,a},
a=(3 Sqrt[(16+8 h+h^2)/(2+h)])/Sqrt[2];
\[ScriptCapitalR]=ImplicitRegion[x^2+y^2> 16&&x^2/a^2+(y+h)^2/(h+4)^2< 1&&x>0&&y>0,{x,y}];
DiscretizeRegion[\[ScriptCapitalR]]
]
![area][6]
Compute the area of the region by:
Area[%]
=> 4.45849
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=102041.jpg&userId=23928
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2571loop.gif&userId=23928
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1.PNG&userId=23928
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2.PNG&userId=23928
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4190loop2.gif&userId=23928
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=area.PNG&userId=23928Shenghui Yang2019-02-14T11:37:15ZUse ParametricPlot to show the results of NDSolve?
https://community.wolfram.com/groups/-/m/t/1613368
Im trying to show the results of NdSolve by using Parametric Plot.These are pendulum equations and I want to get phase-space trajectories of this system. For small angles like Pi/5 i should get a circle.Here is my code
pend[\[Theta]0, \[Omega]0, \[Gamma], \[CurlyPhi]0, \[Omega]D, T] :=
NDSolve[{\[Theta]'[t] == \[Omega][t], \[Omega]'[
t] == -\[Gamma]\[Omega][t] -
Sin[\[Theta][t]] + \[CurlyPhi]0 Cos[\[Alpha][t]], \[Alpha]'[
t] == \[Omega]D, \[Theta][0] == \[Theta]0, \[Omega][
0] == \[Omega]0, \[Alpha][0] ==
0}, {\[Theta], \[Omega], \[Alpha]}, {t, 0, T}];
sol1 = pend[Pi/5, 0, 0, 0, 0, 100];
ParametricPlot[
Evaluate[{{\[Theta][t], \[Omega][t]} /. sol1}], {t, 0, 30},
PlotRange -> All, Frame -> True]
I keep getting the error message that the result of NDSolve " is neither a list of replacement rules nor a valid dispatch table, so cannot be used for replacing". I don't know how to fix it. I would appreciate your help very much.Paweł Żukowski2019-02-14T14:59:58ZPlot a Dirac Delta Function?
https://community.wolfram.com/groups/-/m/t/1611541
Good Evening All,
I have stumbled across a Dirac Delta Function, when applying the Fourier Transform to a function. I am not quite sure how to plot it. Could anyone provide some guidance?
Thanks!
F[t_] := A*Sin[ t]
g[k_] := FourierTransform[F[t], t, k]
I A Sqrt[\[Pi]/2] DiracDelta[-1 + k] -
I A Sqrt[\[Pi]/2] DiracDelta[1 + kLuciano Pinheiro2019-02-13T02:10:21ZAvoid error while using NDSolve on theses differential equations?
https://community.wolfram.com/groups/-/m/t/1612266
Im trying to solve the differential equations and I keep getting the message error "NDSolve called with 2 arguments; 3 or more arguments are expected". My code is
pend[a0, w0, k, l, wd] =
NDSolve[{a'[t] == w[t], w'[t] == -k w[t] - Sin[a[t]] + l Cos[q[t]],
q'[t] == wd, a[0] == a0, w[0] == w0, q[0] == 0}, {a, w, q}, {t, 0,
100}];
Any help with this is greatly appreciated.Paweł Żukowski2019-02-13T19:58:29ZSimulating Finite Automata (and making it look nice)
https://community.wolfram.com/groups/-/m/t/1611589
![The simulation in action][1]
![a plot of a nondeterministic finite automaton, AddBin3 that recognizes a set of 3-digit binary numbers whos first two columns add up to its' third colum][2]
The above nondeterministic finite automaton recognizes a language I will call AddBin3. The alphabet for this NFA is the set of 3-digit binary numbers ({0,0,0},{0,0,1},...{1,1,1}}. The language includes all strings whose first 2 rows add up to the third row. So {1,0,1} (1+0=1} would be part of the language and {0,0,1},{1,1,0} (01+01=10), but not {1,1,1}.<br>
To simulate the states the automaton passes given a certain input string is fairly simple using **FoldList**. We simply pass it the initial state, a set of rules and the input, then apply the rules repeatedly to the set of states.
rule = <|{1, {0, 0, 0}} -> {0,
1}, {1, {0, 0, 1}} -> {2}, {1, {0, 1, 0}} -> {}, {1, {0, 1,
1}} -> {0, 1},
{1, {1, 0, 0}} -> {}, {1, {1, 0, 1}} -> {0,
1}, {1, {1, 1, 0}} -> {}, {1, {1, 1, 1}} -> {},
{2, {0, 0, 0}} -> {}, {2, {0, 0, 1}} -> {}, {2, {0, 1,
0}} -> {2}, {2, {0, 1, 1}} -> {},
{2, {1, 0, 0}} -> {2}, {2, {1, 0, 1}} -> {}, {2, {1, 1, 0}} -> {0,
1}, {2, {1, 1, 1}} -> {2},
{0, {0, 0, 0}} -> {}, {0, {0, 0, 1}} -> {}, {0, {0, 1,
0}} -> {}, {0, {0, 1, 1}} -> {},
{0, {1, 0, 0}} -> {}, {0, {1, 0, 1}} -> {}, {0, {1, 1,
0}} -> {}, {0, {1, 1, 1}} -> {}
|>;
FoldList[Union @@ (Function[s, rule[{s, #2}]] /@ #1) &, {1}, {{0, 0,
1}, {1, 1, 0}, {1, 0, 1}}]
Output: {{1}, {2}, {0, 1}, {0, 1}}
As we see, the automaton starts in state 1, moves to state 2, then moves on to states 0 and 1.<br>
To make this nicer to read, I made a more elaborate version, which has more information (the initial state, the accept state(s), the rule, etc. It outputs a quite elaborate **StringTemplate** that I thought was worth sharing.
addBin3Simulation[input_List]:=
((*set the initial state, accept state(s), alphabet, and rules*)
initialstate={1};
acceptstates= {0};
alphabet={{0,0,0},{0,0,1},{0,1,0},{0,1,1},{1,0,0},{1,0,1},{1,1,0},{1,1,1}};
rule=<|{1,{0,0,0}}->{0,1},{1,{0,0,1}}->{2},{1,{0,1,0}}->{},{1,{0,1,1}}->{0,1},
{1,{1,0,0}}->{},{1,{1,0,1}}->{0,1},{1,{1,1,0}}->{},{1,{1,1,1}}->{},
{2,{0,0,0}}->{},{2,{0,0,1}}->{},{2,{0,1,0}}->{2},{2,{0,1,1}}->{},
{2,{1,0,0}}->{2},{2,{1,0,1}}->{},{2,{1,1,0}}->{0,1},{2,{1,1,1}}->{2},
{0,{0,0,0}}->{},{0,{0,0,1}}->{},{0,{0,1,0}}->{},{0,{0,1,1}}->{},
{0,{1,0,0}}->{},{0,{1,0,1}}->{},{0,{1,1,0}}->{},{0,{1,1,1}}->{}
|>;
(*Fold the rule over and over on the states to get a list of the sequence of states*)
states=FoldList[Union@@(Function[s,rule[{s,#2}]]/@#1)&,initialstate,input];
(*check that all the characters in the input string are part of the alphabet*)
If[ContainsOnly[input,alphabet],
(*if they are, output the result of the simulation*)
StringRiffle[
Join[
(*First, output the initial state*)
{StringTemplate["The intial state of the NFA is \!\(\*SubscriptBox[\(q\), \(``\)]\)`"][initialstate]},
(*Then, show the sequence of states reached through the input*)
(*adjust the output depending on the number of states for correct grammar*)
(*have a special output for an empty list*)
MapThread[StringTemplate["After the next input `1`, the new state <*
If[Length[#2]==1,
\" is \"<>#2[[1]],
\"s are\" <>
If[Length[#2]==0,
\" none. The NFA terminates here.\",
StringRiffle[Most[#2],{\" \", \",\", \" and \"}]
<>Last[#2]]]*>"],
{input,Map[StringTemplate["\!\(\*SubscriptBox[\(q\), \(`1`\)]\)"],Rest[states],{2}]}
(*terminate the MapThread loop after the first empty list*)
[[All,;;FirstPosition[Rest[states],{},{-1}][[1]]]]],
(*attach a statement weather the string was accepted or not*)
{If[Last[states]!= {},
"This is the last state and "<>If[ContainsAny[Last[states],acceptstates],
"the string is accepted.",
"the string is not accepted."],
"The string is not accepted."]}],
"\n"],
(*if the input characters are not all in the alphabet, output an error message*)
"Error: One or more of the input characters are not in the alphabet"])
When we give this function an input string, it will give us information in an easily digestible format.<br>
Some examples:
![enter image description here][3]
The function will also give an Error when the string has characters that are not in the language.<br>
Of course, this function can be generalized for other NFAs:
(*generalied NFA simulation*)
nfaSimulation[alphabet_List, initialstate_List, rule_Association,
acceptstates_List, input_List] :=
((*Fold the rule over and over on the states to get a list of the \
sequence of states*)
states =
FoldList[Union @@ (Function[s, rule[{s, #2}]] /@ #1) &,
initialstate, input];
(*check that all the characters in the input string are part of the \
alphabet*)
If[ContainsOnly[input, alphabet],
(*if they are, output the result of the simulation*)
StringRiffle[
Join[
(*First, output the initial state*)
{StringTemplate[
"The intial state of the NFA is \!\(\*SubscriptBox[\(q\), \
\(``\)]\)`"][initialstate]},
(*Then,
show the sequence of states reached through the input*)
(*
adjust the output depending on the length of the list of states \
to have correct grammar*)
(*have a special output for an empty list*)
MapThread[
StringTemplate[
"After the next input `1`, the new state <*If[Length[#2]==1, \
\" is \"<>#2[[1]], \"s are\" <>If[Length[#2]==0, \" none. The NFA \
terminates here.\", StringRiffle[Most[#2],{\" \", \",\", \" and \
\"}]<>Last[#2]]]*>"],
{input,
Map[StringTemplate["\!\(\*SubscriptBox[\(q\), \(`1`\)]\)"],
Rest[states], {2}]}
(*terminate the MapThread loop after the first instance \
of an empty list*)
[[All, ;; FirstPosition[Rest[states], {}, {-1}][[1]]]]],
(*attach a statement weather the string was accepted or not*)
\
{If[Last[states] != {},
"This is the last state and " <>
If[ContainsAny[Last[states], acceptstates],
"the string is accepted.",
"the string is not accepted."],
"The string is not accepted."]}],
"\n"],
(*if the input characters are not all in the alphabet,
output an error message*)
"Error: One or more of the input characters are not in the \
alphabet"])
We just need to give this function the alphabet, initial state, rule, acceptstates and an input and it will generate a narrative about the computation of the NFA.
![a generalized version of the simulator in action][4]
<br>
<br>
Bonus: here is how I draw NFAs with the WL.
nfaPlot[q_, q0_, transitions_, f_,
opts___] := (g \[Function]
Graph[g,
VertexShape ->
Join[Thread[
Complement[VertexList[g], f, {q0}] -> Graphics[Circle[]]],
Thread[DeleteCases[f, q0] ->
Graphics[{Circle[], Circle[{0, 0}, 0.8]}]], {q0 ->
Graphics[{If[MemberQ[f, q0], Circle[{0, 0}, 0.8], Nothing],
Thickness[0.05], Circle[]}]}], VertexSize -> Large,
EdgeStyle -> Black, opts])@
Graph[q, Labeled[#1 \[DirectedEdge] #2,
If[Length[#3] === 1, #3[[1]], #3]] & @@@
KeyValueMap[Append,
GroupBy[transitions, (#[[;; 2]] &) -> (#[[3]] &)]]]
nfaPlot[Labeled[#, Style[Subscript["q", #], Large], Center] & /@ {0,
1, 2}, 0,
MapAt[Style[#, Large, Italic,
FontFamily -> "Times New Roman"] &, {{0, 1, 1}, {1, 2, 1}, {2, 0,
1}, {1, 0, 0}, {2, 1, 0}, {0, 2, 0}}, {All, 3}], {2}]
The output looks like the image below. The initial state is marked by a bold circle, but feel free to manually draw an arrow leading into the diagram like I did above:
<br>![an example DFA][5]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Examples.JPG&userId=1340981
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10097AddBin3.jpg&userId=1340981
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Examples.JPG&userId=1340981
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Example2.JPG&userId=1340981
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=examplegraph.jpg&userId=1340981Katja Della Libera2019-02-13T13:39:00ZSolve eight order polynomial with variable coefficients?
https://community.wolfram.com/groups/-/m/t/1611146
I want to solve eight order following polynomials and obtain the x depending on alpha.
Aj=Aj(alpha)
A8 * x^8 + A7 * x^7 + A6 * x^6 + A5 * x^5 + A4 * x^4 + A3 * x^3 + A2 * x^2 + A1 * x +
A0=0
How do I get this? Is it possible?
Thanks,Isa Comez2019-02-12T08:52:27ZAvoid a syntax error while calculating jet velocities?
https://community.wolfram.com/groups/-/m/t/1610724
I keep receiving this syntax error. Anyone have an idea as to why?Dan Rivera2019-02-11T20:18:16ZFrustration Solitaire
https://community.wolfram.com/groups/-/m/t/1609558
## Frustration Solitaire ##
Frustration solitaire is a game that has roots stemming from the early 1700's. The rules of the game are simple: a dealer calls out the ranks of cards in order $\textit{Ace, Two, Three, . . .}$ and so on. At the same time the dealer draws a card from a sufficiently well shuffled deck. If the rank of the card drawn matches the rank of the card the dealer says you lose the game.
![cards][1]
The rank of the cards the dealer would have called out are $\textit{Ace, Two, Three, Four, Five}$. Since the fifth card has rank five we lose.
Let's programme a game of frustration solitaire.
We start by creating an array that corresponds to the ranks of the cards the dealer calls out.
dealer = Flatten[Table[Range[1, 13], 4]]
Next, we need to simulate a well shuffled deck of cards. Using the function `RandomSample[]` we can easily "shuffle" the deck of cards.
shuffle = RandomSample[Flatten[Table[Range[1, 13], 4]]]
Combine the lists using `Transpose[]` to get our very own game of frustration solitaire.
In[1]:= fs =
Transpose[{Flatten[Table[Range[1, 13], 4]],
RandomSample[Flatten[Table[Range[1, 13], 4]]]}]
Out[1]= {{1, 11}, {2, 9}, {3, 8}, {4, 9}, {5, 8}, {6, 5}, {7, 9}, {8,
6}, {9, 5}, {10, 2}, {11, 4}, {12, 13}, {13, 5}, {1, 10}, {2,
7}, {3, 12}, {4, 13}, {5, 1}, {6, 12}, {7, 4}, {8, 1}, {9, 2}, {10,
7}, {11, 10}, {12, 13}, {13, 10}, {1, 8}, {2, 3}, {3, 9}, {4,
11}, {5, 3}, {6, 3}, {7, 10}, {8, 8}, {9, 6}, {10, 5}, {11, 2}, {12,
7}, {13, 11}, {1, 12}, {2, 12}, {3, 6}, {4, 3}, {5, 1}, {6, 1}, {7,
7}, {8, 2}, {9, 13}, {10, 4}, {11, 6}, {12, 4}, {13, 11}}
Lets see if we have won:
In[2]:= w1 =
If[Part[fs[[#]], 1] == Part[fs[[#]], 2], 1, 0] & /@
Range[Length[fs]];
In[3]:= If[Length[DeleteCases[0]@w1] == 0,
"YOU WIN!", "YOU LOSE."]
Out[3]= "YOU LOSE"
Now we shouldn't feel *too* bad about losing. The name "frustration" solitaire stems from the fact that the percentage of winning is actually very low. In 2009, Doyle et. al. found out that the percentage of winning a game of frustration solitaire is approximately $1.62\%$. They worked this out by framing the question within the world of combinatorics. Finding the percentage of winning a game of frustration solitaire is equivalent to finding the number of rank derangements (i.e. how many permutations that have no rank-fixed points) divided by $52!$ (i.e. the total number of permutations of a deck of cards).
Let's generate 100,000 games of frustration solitaire and see how close we can get to the estimate Doyle et. al. produced.
In[4]:= trials =
Table[s =
Transpose[{Flatten[Table[Range[1, 13], 4]],
RandomSample[Flatten[Table[Range[1, 13], 4]]]}];
If[Length[
DeleteCases[
If[Part[s[[#]], 1] == Part[s[[#]], 2], 1, 0] & /@
Range[Length[s]], 0]] == 0, 0, 1], 100000];
In[5]:= winning = (1 - Total[trials]/100000)*100// N
Out[5]= 1.61
In our 100,000 games of frustration solitaire we won $1.61\%$ of the time, hence the title of "frustration" solitaire is very well deserved.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=c.png&userId=1598258William Rudman2019-02-09T21:11:54ZQubase: a database experiment - remote consultant needed
https://community.wolfram.com/groups/-/m/t/1601681
I plan to write a research proposal/paper on what I have been calling Qubase. It's a proposed database using all the lessons learned from relational databases and partially inspired by quantum theory (though intended for classical computers). Qubase is intended to use a spherical coordinate system and abstract spatial connections and functions to describe relations between objects, rather than keyed tabular data. The project stems from my inability to understand relational algebra but my mild ability to understand calculus (lol). Instead of cartesian products, unions, and similar algebraic results, I propose to respond to queries as spherical or arbitrary spatial volumes of result sets. Among other benefits, this would seem to make visualization and network analysis-type tasks very straightforward. I want to model all of it in Mathematica. I have not put pen to paper yet, but these are concepts I have been thinking about for months and they are coalescing into an idea that I think may be conceptually possible. Definitely will need a consultant who is familiar with the current state of the art and other areas.
Looking for an hourly consulting expert in Mathematica who has an interest in databases, data structures, and calculus. Thanks.Andrew Watters2019-01-30T13:25:33ZLabeled Cube
https://community.wolfram.com/groups/-/m/t/1610082
How to label faces of a cube with numbers 1 to 6? First, I'll turn text outlines into polygons.
SymbolToPolygon[symbol_, dimension_: "3D"] :=
Module[{pol, poly, index, pos, minmax, diffs, poly2D},
pol = (Cases[ImportString[ExportString[symbol, "PDF"], "PDF"], _FilledCurve, \[Infinity]][[1, 2]]);
poly = pol[[1]];
index = 2;
While[index <= Length[pol],
pos = Position[poly, Nearest[poly, pol[[index, 1]]][[1]]][[1, 1]] ;
poly = Join[Take[poly, pos], Reverse[pol[[index]]], Drop[poly, pos - 1]];
index++];
minmax = MinMax /@ Transpose[poly];
diffs = #[[2]] - #[[1]] & /@ minmax;
poly2D = (# - Mean /@ minmax)/Max[diffs] & /@ poly;
If[dimension === "2D", Polygon[poly2D], Polygon[Append[#, 1] & /@ poly2D]]]
After that, rotations and the cube
tab={{0,{0,1,0}},{Pi/2,{0,1,0}},{Pi/2,{1,0,0}},{-Pi/2,{1,0,0}},{-Pi/2,{0,1,0}},{Pi,{0,1,0}} };
Graphics3D[Table[Polygon[SymbolToPolygon[ToString[n]][[1]].RotationMatrix[tab[[n,1]],
tab[[n,2]]]],{n,1,6}]]
![labeled cube][1]
Can anyone improve on that?
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=labeledcube.jpg&userId=21530Ed Pegg2019-02-11T18:12:10ZMaximize the solution of an equation containing an integral?
https://community.wolfram.com/groups/-/m/t/1610261
I have to find `{x,y}` which makes the integral
NIntegrate[(1/(E^((x^2 - 2*x*d + d^2 + y^2 )/(2*(d + r^2)))*
(Sqrt[d]*(d + r^2)))), {d, 0, Infinity}]
equal to `Pi^0.5/Ry`. Among all the possible solutions, I am interested in the one which maximises y, with the constraint `y>0`. I have also a good starting point for y. The problem has to be solved for different values of `r`, say from 0 to 20, and `Ry`, say from 10^-7 to 10^7.
I have set the problem in this way:
f2[x_?NumberQ, y_?NumberQ, r_?NumberQ] :=
NIntegrate[(1/(E^((x^2 - 2*x*d + d^2 + y^2 )/(2*(d + r^2)))*
(Sqrt[d]*(d + r^2)))), {d, 0, Infinity}];
solu2 = Table[
FindMaximum[{y, f2[x, y, r] == Sqrt[\[Pi]]/Ry, y > 0}, {x, y}], {r,
ranger}, {Ry, rangeRy}]
Unfortunately, `NIntegrate` fails to converge to the solution for all the values of `r` and Ry.
Any help?umby piscopo2019-02-11T11:24:01ZSolve numerically a diffusion equation with fully reflecting wall?
https://community.wolfram.com/groups/-/m/t/1610358
I am trying to solve numerically the diffusion equation $\partial_t P(x,t)=\partial_x^2 P(x,t)+ \partial_x V'(x)P(x,t)$. I have a potential that diverges at zero: $V(x)=4((1/x^4)-(1/x^2))$, therefore, I want to set a reflecting wall at, say xc=0.5, and solve only for x>xc.
1. In the code below, you will see my unsuccessful attempt in placing thes boundary conditions.
2. Since I found that I cannot use DiracDelta and HeavisideTheta functions to set my initial condition, I use instead $Pinit(x)=\exp(-(x-8)^2)/\sqrt{\pi}$, which has a negligible contribution from x<=0.
3. It seems that even though, mathematically I believe I am setting a reflecting wall condition, which should not allow any flow to the region below x<xc, it seems that numerically this still happens. And eventually it make the end solution u[x,T] not normalized correctly.
How do I achieve my goal above, to solve this equation only on the positive half-plane?
The following code shows a negative part for $u(x,T)$, which should not have existed, and I belive it is responcible for $\int_0^\infty u(x,T)dx\neq1$.
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"]
V[x] = ((1/x)^4 - (1/x)^2) 4;
F[x] = -4 (-(4/x^5) + 2/x^3)
x0 = 8;
Pinit[x] = Exp[-(x - x0)^2]/(Sqrt[Pi]);
T = 1000;
BoundaryCondition = 50;
mol[n_Integer, o_: "Pseudospectral"] := {"MethodOfLines",
"SpatialDiscretization" -> {"TensorProductGrid", "MaxPoints" -> n,
"MinPoints" -> n, "DifferenceOrder" -> o}}
uval = NDSolveValue[{D[u[x, t], t] + D[F[x]*u[x, t], x] -
D[u[x, t], x, x] == 0,
u[x, 0] == Pinit[x], (D[u[x, t], x] /. x -> 0.5) == 0,
u[0.5, t] == 0}, u, {x, 0.5, BoundaryCondition}, {t, 0, T},
Method -> mol[2000, 4]];
Plot[{uval[x, T]}, {x, -5, 5}, PlotRange -> All,
PlotStyle -> {Automatic, {Thick, Dashed}}]Erez A2019-02-11T10:08:16ZCalculate (9^9)! and retrieve specific 5 digits from result?
https://community.wolfram.com/groups/-/m/t/1608085
Hi,
to solve a puzzle I shall calculate the big number (9^9)!.
Now I need to retrieve the 5 numbers at the digits 97550930-97550925 (to the right).
Which term do I need to enter in WolframAlpha in oder to solve this and do I need to have another plan then the basic plan to do so?
Thx for help.Veit Schmitt2019-02-08T09:57:27Z[GIF]Concentric Geometry Visual Illusion
https://community.wolfram.com/groups/-/m/t/1609912
*Please Download the attached notebook at the end of the discussion*
----------
![illusion][1]
[@xponential][2] is a popluar visual aritist on twitter. I found [one of his/her masterpiece][3] very appealing and I want to give it a try in Wolfram Language. The replication above is generated solely with the code below and in the attached notebook. The scale of the width of the vertical striple to the thickness of annuli is estimated from the origin work.
##Know-how
The key components in the animation are
- [Rectangle][4]
- [Annulus][5]
The key operations are
- [DiscretizeRegion][6] ( to break a region in to mesh )
- [RegionIntersection][7] (to find overlapping area )
- [MeshPrimitives][8] ( to convert mesh region to graphics objects )
- [Graphics][9] ( to display)
Every frame is compose of irregular shape of tiles. The black tiles are computed and the white ones are simply void, bounded by its black tile neighbours.
The interesting visual affect of each frame can be further divided into an array of vertial patterns. Black tiles aligned vertically are intersections of many annuli and a bar. The adjacent bars are designed to intesect with a different set of annuli, denoted by `region1` and `region2`:
region1 =
DiscretizeRegion /@ {
Annulus[{0, 0}, {1, 2}],
Annulus[{0, 0}, {3, 4}],
Annulus[{0, 0}, {5, 6}],
Annulus[{0, 0}, {7, 8}],
Annulus[{0, 0}, {9, 10}],
Annulus[{0, 0}, {11, 12}]
};
Of course you can find a easy way to generate the above with `Table` or `Map` functions. Similarly, `region2` is defined as
region2 =
DiscretizeRegion /@ {
Disk[],
Annulus[{0, 0}, {2, 3}],
Annulus[{0, 0}, {4, 5}],
Annulus[{0, 0}, {6, 7}],
Annulus[{0, 0}, {8, 9}],
Annulus[{0, 0}, {10, 11}],
Annulus[{0, 0}, {12, 13}]
};
Run these codes to illustrate the alternating bulleyes:
n=9;opt=PlotRange->{{-n,n},{-n,n}};
g1=Graphics[MeshPrimitives[#,2]&/@region1,opt];
g2=Graphics[MeshPrimitives[#,2]&/@region2,opt];
ListAnimate@Flatten@Riffle[ConstantArray[g1,10],{ConstantArray[g2,10]},10]
![loop2][10]
The tiling on two adjacent bars are generated by
With[{k = 0.9}, Graphics[
(MeshPrimitives[RegionIntersection[
Rectangle[{k, -12}, {k + 1.2, 12}], #], 2] & /@ region1)
~Join~
(MeshPrimitives[RegionIntersection[
Rectangle[{k - 1.2, -12}, {k, 12}], #], 2] & /@ region2)
, PlotRange -> {-9, 9}]
] // Rotate[#, 90 Degree] &
![pattern1][11]
( I rotate the tile 90 degree to have it better fit into this webpage )
Because I am not doing any furtuer hefty operations based on the regions, I use `MeshPrimitives` to convert these regions into simple polygons. Then I use `Graphics` display all items in a panel. `RegionUnion` should not be used here to save computation time.
In the demo above I use only two vertical bars. To accomodate more bars in a similar computation, I declared the following function:
findMosaics[rect_, rings_] :=
With[{objs =
DeleteCases[RegionIntersection[rect, #] & /@ rings, _EmptyRegion]},
MeshPrimitives[#, 2] & /@ objs]
It picks a bar and map an Intersection function all over the list of annuli in either `region1` or `region2`. The returned values are converted to simple graphics object. Ready to be used in the next round!
`Riffle` the annuli into alternating patter. Then generate a single frame
rings = Riffle[ConstantArray[r2, 20], ConstantArray[r3, 20]][[;; 31]];
frame1 = With[{k = 0.9},
rects =
Table[Rectangle[{k + i*1.2, -12}, {k + (i + 1)*1.2, 12}], {i, -15,
15}];
MapThread[findMosaics, {rects, rings}]
];
Graphics[frame1, PlotRange -> {{-9, 9}, {-9, 9}}]
![pattern2][12]
Use `Table` or `Map` to generate more frames. The parallel version is handy in this case as well:
In[92]:= LaunchKernels[]
Out[92]= {KernelObject[1,local],KernelObject[2,local],KernelObject[3,local],KernelObject[4,local],KernelObject[5,local],KernelObject[6,local]}
frames = ParallelTable[
With[{k = step},
rects =
Table[Rectangle[{k + i*1.2, -12}, {k + (i + 1)*1.2,
12}], {i, -15, 15}];
Graphics[MapThread[findMosaics, {rects, rings}],
PlotRange -> {{-9, 9}, {-9, 9}}]
],
{step, -1.2, 1.2, 0.08}, Method -> "FinestGrained"];
I observe very even loads on subkernels with embarrassing parallelism.
![parallel][13]
Finally, I inspect the animation in notebook with `ListAnimate` before `Export["animation.gif", frames]` :
![test][14]
##Beyond the original concentric circles
Wolfram Language's versatility is top notch. Once you learn by heart the code above, you can create more fancy art with in-house polygon data. Simply call the following NLP or W|A query
![nlp][15]
![code][16]
Create 15 "concentric" `{5,2}`-star rings, include the solid one at the center:
root=starlist[[1]];
regions=Prepend[ListConvolve[{0,0},Rest@starlist,1,root,#2&,RegionDifference[#2,#1]&],root];
(*the effect is {star1,star2,star3 ... } => {RegionDiff[star2,star1], RegionDiff[star3,star2]... }*)
where `RegionDifference` is an instance of [the more general set difference operation][17]. `ListConvolve` used in the form is a good template to do neibourbood operation in functional programming style.
Again, use the code in alternating annuli to observe the same pattern for star-shape rings:
![starflash][18]
Use the same code that generates single frame in the first case to these star-shaped rings. Well, as a bonus, let me apply this function to all star polygon available ( Proposal for Computational Tatoo) :
![collection][19]
Use the same code with `ParallelTable` to generate animation:
![movingstar][20]
##About @xponential and @AkiyoshiKitaoka
Assume you have a valid twitter account, download the attached notebook and use `ServiceConnect` to find more about visual artist @xponential and @AkiyoshiKitaoka their cyber art gallery:
twitter = ServiceConnect["Twitter"]
twitter["UserData", "Username" -> "AkiyoshiKitaoka"] // Dataset
twitter["UserData", "Username" -> "xponential "] // Dataset
![res][21]
That's all I want to share in this discussion. Enjoy coding ~
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1547loop.gif&userId=23928
[2]: https://twitter.com/xponential
[3]: https://twitter.com/xponential/status/1093853227240640513
[4]: https://reference.wolfram.com/language/ref/Rectangle.html
[5]: https://reference.wolfram.com/language/ref/Annulus.html
[6]: https://reference.wolfram.com/language/ref/DiscretizeRegion.html
[7]: https://reference.wolfram.com/language/ref/RegionIntersection.html
[8]: https://reference.wolfram.com/language/ref/MeshPrimitives.html
[9]: https://reference.wolfram.com/language/ref/Graphics.html
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5599loop2.gif&userId=23928
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pattern1.PNG&userId=23928
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=pattern2.PNG&userId=23928
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=parallel.png&userId=23928
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=inspect.PNG&userId=23928
[15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=nlp.PNG&userId=23928
[16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=starring.PNG&userId=23928
[17]: http://mathworld.wolfram.com/SetDifference.html
[18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1677loop3.gif&userId=23928
[19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10216res.PNG&userId=23928
[20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4905loop3.gif&userId=23928
[21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2122res.PNG&userId=23928Shenghui Yang2019-02-10T12:38:12ZCount dimensions with AccountingForm?
https://community.wolfram.com/groups/-/m/t/1609933
Hello guys.
y = {{5.0995928*^7, 1032}, {189615., 881}, {99906.,
875}, {4.569987*^6, 364}, {5.091084*^6, 414}, {2.915453*^6, 556}}
x = AccountingForm[y // MatrixForm, DigitBlock -> 3,
NumberSeparator -> " "]
Dimensions[x[[1]]]
Having AccountingForm I cant count dimensions. How to count dimensions with AccountingForm . Thanks in advance! Of course, I can separately do it from y, but sometimes I need to count it from x.Alex Graham2019-02-10T14:58:22ZAn algorithm on divisibility
https://community.wolfram.com/groups/-/m/t/1608875
I put on your consideration this algorithm to know if an odd number S is divisible by another number (called "primo" here) :
DivisibleQ[S_, primo_ ] (* S is odd and primo>5 *) :=
Module[{factor = ModularInverse[primo - 10, primo] , numero = S},
While[numero > primo,
numero = FromDigits[Most[IntegerDigits[numero]]] - factor * Last[IntegerDigits[numero]]];
If [numero < 0, While[numero < 0, numero = numero + primo],
While[numero > 0, numero = numero - primo]];
If[numero == 0, True, False]]
Very simple, fast, general and economic. I hope you like it. Free to use naming the source; I named it EGP algorithm. I post it here because I want to share it with all the users of Mathematica.
All suggestions are welcome.Eloy Gonzalez2019-02-09T00:15:32Z