Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Mathematics sorted by activeHow would you make mathematica solve for a variable in degrees?
https://community.wolfram.com/groups/-/m/t/1880922
Hi! This is my first thread here, so I'm sorry if I missed any formatting rules or such, but I had a question:
I'm somewhat new to Mathematica so I'm having some issues, here, I'm trying to use the program to do my trig homework.
Basically, I need to use the law of sines to solve triangles. I'm given certain angles (in degrees) and side lengths, and I have to give all side lengths and angles (in degrees again). Here is the problem:
Using sin(a)/A=sin(b)/B=sin(c)/C, if I'm given, for example, a=40 degrees; A=2, b=20 degrees, I can plug in NSolve[Sin[40Degree]/4 == Sin[20Degree]/b, b, 3], and I can use this to find B (I rounded to 2 decimals because I'm asked to round to the nearest whole number, and I haven't learned rounding yet, so I use NSolve and round). Of course, I can find the 3rd angle by using 180-a-b and repeat the process so, as far as that goes, I'm good.
Now, if I'm given a, A, B, and told to find all 3 angles and sides, I plug this in:
NSolve[Sin[20 Degree]/4 == Sin[b/Degree]/6, b, 3]
When I go to run this, here's what it gives: ![image][1]
I know I could just do the cross multiplication but, well, this stuff is just all very easy but tedious work I'm trying to slowly learn how to do, so that I can eventually do all of my tedious work this way without having to bother using a lot of loose-leaf, so, does anyone know how to make mathematica just output a straightup answer b-> answer in degrees, with just one line of code I could just change the numbers on for each triangle? Thanks!
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=hereitis.PNG&userId=1872959Robin Ruatta2020-02-18T00:08:41ZPassing BezierFunction to ArcLength?
https://community.wolfram.com/groups/-/m/t/1875471
I have a cubic Bezier curve I've generated:
pts = RandomReal[1,{4,2}];
f = BezierFunction[pts];
For a particular value of t, f will return a 2D vector:
In[21]:= f[0.5]
Out[21]= {0.584105,0.651064}
However, if I pass f by itself to ArcLength, it fails to evaluate:
ArcLength[f[t], {t,0,1}] //N
NIntegrate: Integrand ... is not numerical at {t}={0.00795732}
The same general procedure works fine with other vector-valued functions I've defined myself:
In[30]:= g[t_]:={t,t}
In[31]:= ArcLength[g[t], {t,0,1}]
Out[31]= SqrtBox["2"]
What's the correct way to do this?Nicholas Kitten2020-02-09T18:15:58Z[GIF] Square Grid (Schwarz–Christoffel mapping from circle to square)
https://community.wolfram.com/groups/-/m/t/1879730
![Schwarz–Christoffel transformation between circle and square][1]
**Square Grid**
This shows a parametrized version of the [Schwarz–Christoffel transformation][2] between the circle and the square.
To implement this, first of all we need the Cayley transformation between the upper half-plane and the unit disk:
Cayley[z_] := (z - I)/(z + I);
Now, I took some inspiration from a [Math StackExchange answer of Lukas Geyer][3] to realize that this particular Schwarz–Christoffel mapping could be implemented using the Weierstrass $\wp$-function. We need to determine the specific parameters that will give us our map:
g2[ω1_, ω2_] := Block[{a, b, τ, q},
τ = ω2/ω1;
q = E^(π I τ);
a = EllipticTheta[2, q];
b = EllipticTheta[3, q];
4/3 (π/ω1)^4 (a^8 - a^4 b^4 + b^8)
];
g3[ω1_, ω2_] := Block[{a, b, τ, q},
τ = ω2/ω1;
q = E^(π I τ);
a = EllipticTheta[2, q];
b = EllipticTheta[3, q];
8/27 (π/ω1)^6 (a^12 - 3/2 a^8 b^4 - 3/2 a^4 b^8 + b^12)
];
And then it's basically just a matter of choosing colors and fiddling with the interpolation:
DynamicModule[{invts = {g2[2., 2. I], g3[2., 2. I]}, s, width = .012,
n = 8, c, cols = RGBColor /@ {"#21243d", "#88e1f2"}},
s = WeierstrassP[1, invts];
Manipulate[
c = 2 Cos[t] # + Sin[t] Cayley[-WeierstrassP[#, invts]/s] &[(1 + I)/2];
Graphics[{FaceForm[cols[[-1]]],
Table[
Polygon[
Join @@
Transpose[
Table[
ReIm[-c + 2 Cos[t] # + Sin[t] Cayley[-WeierstrassP[#, invts]/s]]
& /@ {x + I (y - width), 1 - x + I (y + width)},
{x, -width, 1 + width, (1 + 2 width)/100}]]],
{y, 0., 1, 1/n}],
Table[
Polygon[
Join @@
Transpose[
Table[
ReIm[-c + 2 Cos[t] # + Sin[t] Cayley[-WeierstrassP[#, invts]/s]]
& /@ {x - width + I y, x + width + I (1 - y)},
{y, -width, 1 + width, (1 + 2 width)/100}]]],
{x, 0., 1, 1/n}]},
ImageSize -> 540, PlotRange -> Sqrt[3], Background -> cols[[1]]],
{t, 0, π}]
]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=squircle14.gif&userId=610054
[2]: https://en.wikipedia.org/wiki/Schwarz%E2%80%93Christoffel_mapping
[3]: https://math.stackexchange.com/a/246625Clayton Shonkwiler2020-02-16T04:04:43ZCalculate the mean curvature and normal vector of a surface?
https://community.wolfram.com/groups/-/m/t/1880004
Is there a code in Mathematica that allows to calculate the mean curvature and normal vector of a surface?Meryem Aslı2020-02-16T19:42:07ZWhere is the scrollbar on step-by-step solutions W|A?
https://community.wolfram.com/groups/-/m/t/1559973
I don't know if I'm missing something obvious, but on my tablet I can't scroll when Wolfram Alpha gives me step-by-step solutions. This is consistent across all queries, so I can only ever see the first step. Sorry if this has been asked, but Google is giving me nothing.
![Problem][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Capture.PNG&userId=1559959Jordan M2018-11-26T20:10:17ZUsing Pseudo-Hilbert Curves to Assist People Perceive Images via Sound
https://community.wolfram.com/groups/-/m/t/1862464
###Introduction###
Recently, I was learning about infinite space filling curves and their applications in real life. I became fascinated with [Hilbert Curves][1], one of many [plane-filling functions][2]. I wanted to see how these shapes could be used in image to video conversion. To begin with, I explored how pseudo Hilbert Curves could be used to convert a square image to audio so that each pixel color was associated with a specific sound.
Theoretically, a person would be able to learn this association and would be able to reconstruct a mental image by listening to audio. This could help with people who are visually impaired, letting blind people "hear" pictures. The reverse is also true. People who are deaf will be able to "see" sound.
I thought I could implement this using Mathematica, which I learned last summer at the Wolfram High School Camp.
###Why Hilbert Curves###
![Pseudo-Hilbert Curves from Order 1 to 10][3]
As you can see above, as you increase the order, the limit of these curves start to fill an infinite amount of space. A true Hilbert Curve is actually $\lim_{n\to\infty} PseudoHilbertCurve_n$. Each one of these curves can be used on an image of dimensions 2 by 2, 4 by 4, 8 by 8, etc. The curve needed is accordingly:
HilbertCurve[Log[2, ImageDimensions[image]]]
Each line in the curve will go over one pixel in the image, starting at the bottom left and ending at the bottom right.
![Example of Order 3 Pseudo Hilbert Curve][4]
But why would you need to use this specific pattern, as supposed to something more simple? Here: https://youtu.be/3s7h2MHQtxc?t=355. In short, if you were to increase the resolution of your image, you would now have to retrain your brain to re-associate the pixel value and the associated frequency at that point on the image. But this is now the case on a Hilbert Curve. As you increase the resolution of your image, and thus the order pseudo-Hilbert Curve, a point will just move closer and closer to its limit in the same space, which solves our problem.
###Converting Color to Sound###
This was the main hurdle when writing the program. I needed to convert each pixel value to a unique sound frequency. My initial thought was to just create an association between each wavelength in the visible electromagnetic spectrum and a frequency, but I was quick to learn that doesn't work in the digital world. RGB colors could be a combination of different wavelengths. And I couldn't just add these wavelengths separately because there could be overlap. There was also brightness and darkness which isn't part of the light spectrum. So instead of the RGB format, I decided to use the HSB format (hue, saturation, and brightness). This is also more compatible for human learning, as the human eye uses these three characteristics to determine color, as supposed to the RGB values on a computer image.
![Graphics3D Visualizer of HSB][5]
As you can see from the image, Hue could be used to determine the color. Now, instead of RGB with three values to one color, Hue gave me one number to a specific color.
![Graphics Hue Color Chart][6]
But I still needed to show saturation and brightness in my sound waves. Color in a computer is expressed in three dimensions while sound has two: amplitude and frequency. I would be leaving one color property out. I could think of multiple ways to express all three as sound waves, but none of them made sure that similar colors sounded the same. For example, if I had a hue playing a certain frequency, I could define a range around this point that could express either saturation or brightness using a plus/minus system.
To solve this, I decided to use [AudioChannel][7] functions. This way, one channel could express the hue through a specific frequency, while the other channel could express the saturation and brightness combined through volume and frequency respectively. This way, colors that were similar would sound similar too.
###Creating the Function###
Obviously, I needed to get real images. I used *image1*, where the pixels were easily noticeable, and my baby picture for the school yearbook as *image2*, as a test image. The first one, being resized to a 8 by 8 image, would utilize an order 3 pseudo-Hilbert Curve ($\log _{2}8=3$), and the second one, being resized to a 32 by 32 image, would utilize an order 5 pseudo-Hilbert Curve ($\log _{2}32=5$).
![The images I used to test the program.][8]
To get the HSB values, I used Wolfram's in-built [Hilbert Curve][9] and [Pixel Value][10] functions. I used Pixel Value to read the image's pixel values as bytes, which was converted to RGB and then to HSB. To get the points on the Hilbert Curve that was associated with their respective position on the image, I added {1,1} to each point so that it matched the pixel space (the origin on a Cartesian Plane is designated as (1,1) on an image).
getHSB[image_] :=
ColorConvert[
RGBColor /@
Divide[PixelValue[
image, ({1, 1} + #) & /@
HilbertCurve[Log[2, ImageDimensions[image][[1]]]][[1]], "Byte"],
255.], "HSB"]
In the Wolfram Language, HSB values range from 0 to 1 instead of the normal 0 to 360 which I guess gives the user more control of the specific color they want to implement. I had to scale these values to the frequency range I wanted for the hue and brightness. Through trial and error, I decided that 100-3900 Hz was a good range so that people of all ages could hear the lowest and highest frequencies. For the amplitude dictated by the saturation, I could just use the direct value as [SoundVolume][11]. I made it so that the sound for each pixel had a duration of 0.1 seconds for demonstrative purposes. In the real world, I would think that this should be a lot smaller so that images don't take too long to hear.
getHSB[image_] :=
ColorConvert[
RGBColor /@
Divide[PixelValue[
image, ({1, 1} + #) & /@
HilbertCurve[Log[2, ImageDimensions[image][[1]]]][[1]], "Byte"],
255.], "HSB"]
hueToFrequencyMatch[HSB_] := Rescale[HSB[[1]], {0, 1}, {100, 3900}]
saturationToAmplitudeMatch[HSB_] := HSB[[2]]
brightnessToFrequencyMatch[HSB_] :=
Rescale[HSB[[3]], {0, 1}, {100, 3900}]
soundFrequency[frequency_] :=
Sound[Play[Sin[frequency*2 Pi t], {t, 0, 0.1}]]
soundFrequencyVolume[frequency_, ampSaturation_] :=
Sound[soundFrequency[frequency], SoundVolume -> ampSaturation]
After this, I just had to apply these functions over the HSB values of each pixel in the order dictated by the appropriate pseudo-Hilbert Curve, and then merge the hue sound and saturation+brightness sound as separate audio channels.
convertHToSound[image_] :=
soundFrequency /@ hueToFrequencyMatch /@ getHSB[image] // AudioJoin
convertBSToSound[picture_] :=
(soundList = {}; n = 1;
While[n <= Length@getHSB[picture],
AppendTo[soundList,
soundFrequencyVolume[
getHSB[picture][[n]] // brightnessToFrequencyMatch,
getHSB[picture][[n]] // saturationToAmplitudeMatch]];
n++])
convertHSBToSound[audio1_, audio2_] :=
AudioChannelCombine[{audio1, audio2}]
Because hue is the most important color characteristic, I wanted to emphasize this AudioChannel more. Thus,
editChannel2[audio_, factor_] := AudioPan[audio, -factor]
To put everything together, I made a separate function to organize the results.
seperateTable[picture_] :=
(convertBSToSound[picture];
Module[{a = convertHToSound[picture], b = soundList // AudioJoin},
c = editChannel2[convertHSBToSound[a, b], 0.05];
table =
Grid[{{Image[picture, ImageSize -> 100], a, b, c}, {Blank[],
AudioPlot@a, AudioPlot@b, AudioPlot@c}}];
ReplacePart[table,
1 -> Prepend[
First[table], {"Image", "Hue", "Saturation+Brightness",
"HSB"}]]])
These were my results. I will attach the *hsb1* and *hsb2* sound files to this post, along with my notebook.
![Final image to sound representation.][12]
Because they use two channels, you should use earbuds or headphones so that you can clearly differentiate the sounds coming through your left and right ears.
![Spectrogram of *hsb1* and *hsb2*][13]
###Visualizing the Process###
animate[image_, audio_] :=
Module[{list = ({1, 1} + #) & /@
HilbertCurve[Log[2, ImageDimensions[image][[1]]]][[1]]},
(AudioPlay@audio;
Animate[
ReplacePixelValue[Image[image, ImageSize -> 100],
list[[1 ;; index]] -> Orange],
{index, 1, list // Length, 1},
DefaultDuration ->
QuantityMagnitude[
UnitConvert[Quantity[audio // Duration, "Seconds"]]],
AnimationRepetitions -> 1])]
I used this to create the following two animations. If you ran these programs, the HSB sound would play alongside the animation, showing exactly which pixel correlates to each sound. Unfortunately, I couldn't play the audio here on the post, but it is in the attached notebook if you would like to see. Here is what it looks like:
![*hsb1* Conversion][14]
![*hsb2* Conversion][15]
###Future Work###
In the future, I hope to create a machine learning algorithm that can learn this association between audio and image in reverse (recreate the image from audio). If anyone has any ideas or pointers for me, please share in the comments below - I would really appreciate it!
[1]: http://mathworld.wolfram.com/HilbertCurve.html
[2]: http://mathworld.wolfram.com/Plane-FillingFunction.html
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-01-19at12.07.19PM.png&userId=1725131
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=example.gif&userId=1725131
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=HSB.png&userId=1725131
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Hue.png&userId=1725131
[7]: https://reference.wolfram.com/language/ref/AudioChannels.html
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-01-19at1.39.00PM.png&userId=1725131
[9]: https://reference.wolfram.com/language/ref/HilbertCurve.html
[10]: https://reference.wolfram.com/language/ref/PixelValue.html
[11]: https://reference.wolfram.com/language/ref/SoundVolume.html
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-01-19at2.23.47PM.png&userId=1725131
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-01-19at2.32.49PM.png&userId=1725131
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animation1.gif&userId=1725131
[15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animation2.gif&userId=1725131
[16]: https://drive.google.com/file/d/1lvjOWkzEzidCDLwYmOmqI4Krz7M_935X/view?usp=sharing
[17]: https://www.wolframcloud.com/obj/srinath.rangan/Published/Hilbert%20Curve%20Project%202.wl?Srinath Rangan2020-01-19T19:42:34Z[Notebook] A precise explanation of the P - Value
https://community.wolfram.com/groups/-/m/t/1824481
&[embedded notebook][1]
[1]: https://www.wolframcloud.com/obj/wolfram-community/Published/A_Precise_Explanation_of_the_P-Value.nbSeth Chandler2019-11-13T16:01:24ZAvoid issue when differentiating Green's function
https://community.wolfram.com/groups/-/m/t/1879508
So I'm trying to plot my Green's function derivative using the following code:
n = 3;
G[x_, xx_] := -1/(2 n) If[x < xx, x^n xx^-n, xx^n x^-n];
DG[x_, xx_] := D[G[x, xx], x];
Plot[DG[x, 0.3], {x, 0, 1}]
While Plot[G] works, trying to plot its derivative gives me some weird errors:
![enter image description here][1]
What's wrong with my code?
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5J4y12h.png&userId=1878894Omer G2020-02-15T18:51:41ZSolve equations with sums?
https://community.wolfram.com/groups/-/m/t/1879931
![equation][2]
<br>
<br>
Hello, I need to solve an equation, which is shown on the picture. It contains sum where *t* elements must be set manually. I'm simply missing how to convert that to *wolfram language*. And solve x, of course
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=CodeCogsEqn%281%29.gif&userId=1879917Pavel Knyazev2020-02-16T20:14:52Z[✓] Make a project about parallel RLC circuit gain and Q?
https://community.wolfram.com/groups/-/m/t/1878957
Hello everybody.
I have a series of Mathematica codes to plot the Gain of a Parallel RLC Circuit and the value of Q, etc.
The codes are attached as a picture.
But, unfortunately, it does not draw a diagram.
Wondering if somebody could tell me the error.
Regards.![enter image description here][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Untitled.jpg&userId=1878925Mohammad Hassan Ramezan zadeh2020-02-14T16:53:15ZProblem with solving inequality x+1/x>-1+1/x
https://community.wolfram.com/groups/-/m/t/1878991
Wolfram|Alpha gives correct answer (-1;0)(0;+infty).
But wolfram script gives (-1;+infty) -- so, with 0 inside answer.
I use this command: Reduce[x+1/x>-1+1/x, x];
Where is a problem with my Wolfram script?Lev Breslav2020-02-14T22:59:16Z[✓] Generate a random connected graph?
https://community.wolfram.com/groups/-/m/t/1837395
As title said, how to generate a random connected graph?
I test the function **RandomGraph**, but it can't make sure to be connected.
How to realized it on Mathematica?Licheng Zhang2019-12-07T09:41:49ZImport a downloaded Cactus Graph program from a web?
https://community.wolfram.com/groups/-/m/t/1618730
Hellow everyone
I downloaded a notebook about Cactus Graph downloaded from *http://mathworld.wolfram.com/CactusGraph.html.* **I want to get all cacti Graph of order 8.**
But I don't know how to **use** the program from it. what should I do ?
thanksLicheng Zhang2019-02-23T05:36:44Z[✓] Understanding fitting with NonlinearModelFit
https://community.wolfram.com/groups/-/m/t/1878205
I'm trying to get a better handle on fitting (using NonlinearModelFit and Fit), and I can't understand why my test problem doesn't work. I'm generating a set of points on a half circle, with some added noise:
randomNums = Table[{x, Sqrt[5^2 - x^2] + Random[]}, {x, -5, 5, 0.5}]
Next I'm simply trying to fit a nlm to this set of data:
nlm = NonlinearModelFit[ randomNums, a Sqrt[b r^2 - c x^2] + d, {a, b, c, d, r}, x ]
However, this just throws back an error that I don't understand:
NonlinearModelFit::nrlnum: The function value {0.653833 +4.89898 I,-2.09763+4.38748 I,-2.43186+3.87298 I,-2.89856+3.3541 I,-3.65104+2.82843 I,-3.59796+2.29129 I,-3.77146+1.73205 I,-4.11906+1.11803 I,-4.72929+0. I,-3.72242+0. I,-3.8093+0. I,-4.07116+0. I,-4.22766+0. I,-4.74941+1.11803 I,-3.93771+1.73205 I,-4.14349+2.29129 I,-3.93865+2.82843 I,-3.55063+3.3541 I,-2.80604+3.87298 I,-1.3348+4.38748 I,0.0544825 +4.89898 I} is not a list of real numbers with dimensions {21} at {a,b,c,d,r} = {1.,1.,1.,1.,1.}.winston carr2020-02-13T16:31:59ZImpression of the Kaprekar´s routine with 5, 6, 7 and 8 digit numbers
https://community.wolfram.com/groups/-/m/t/1869000
# Introduction:
Dattatreya Ramchandra Kaprekar (1905–1986) created a mathematical routine, the Kaprekar´s routine, which is an iterative algorithm that takes a natural number and creates two new numbers, sorting the digits of the initial number in descending and ascending order, and then subtracts the second of the first to provide the natural number for the next iteration. Consequently, he found that 3-digit numbers always arrive at a constant (Kaprekar constant) equal to 495 and 4-digit numbers always converge at a constant (Kaprekar constant) equal to 6174. Another number of digits can only generate cycles or cycles with also other Kaprekar´s constant in a given smaller proportion.
# Objective:
The goal is to test the results of Kaprekar´s routines using numbers with 5, 6, 7 and 8 digits, creating a graphic impression of the cycles. The results should provide information such as: number of iterations until the cycles are found, number of terms in the cycles, if any number converges to a Kaprekar´s constant for a number of digits greater than 4, specific graphic impressions of the cycles for a specific number of digits and the proportions of each result.
# Test of the Method (with 3 and 4 digit numbers):
In this work, I used all the numbers with a certain number of digits sequentially as a sample, covering all the numbers (with 3, 4, 5, 6 and 7 digits). The exception is the final impression with all the 8 digit numbers that I had to use a random distributed sample to run the test as explained later.
In some results of the Kaprekar´s routine, the numbers converge to 0, in cases such as: equal digits (1111), other numbers (2111), etc. In all tests in this work, I excluded the results that converge to 0, as for example, if I used 9000 numbers in the sample (4 digits), the result may have used only 8923 (that is, the difference is the excluded ones that converge to 0).
To test the code, I intended to arrive at the same result for the Kaprekar´s constants, with 3 digits being 495 and 4 digits being 6174.
For example, below, a code to generate random numbers and a code to make the successive iterations of the routine until reaching the converence:
d = 4;
b = 10;
z = RandomInteger[{FromDigits@PadRight[{1}, d],
FromDigits@Table[9, d]}]
![i1][1]
Do[Do[z =
FromDigits@Sort[IntegerDigits[z, b], Greater] -
FromDigits@Sort@IntegerDigits[z, b], 1]; Print[z], 10]
![i2][2]
Confirming the Kaprekar constants for all numbers with 3 and 4 digits (all 900 and 9000 numbers respectively):
d = {3, 4};
b = 10;
n = {900, 9000};
k = DeleteCases[
Table[z =
Range[FromDigits@PadRight[{1}, d[[1]]],
FromDigits@Table[9, d[[1]]]][[ss1]];
Do[z =
FromDigits@Sort[IntegerDigits[z, b], Greater] -
FromDigits@Sort@IntegerDigits[z, b], 15]; z, {ss1, 1, n[[1]]}],
0];
kb = DeleteCases[
Table[zb =
Range[FromDigits@PadRight[{1}, d[[2]]],
FromDigits@Table[9, d[[2]]]][[ss2]];
Do[zb =
FromDigits@Sort[IntegerDigits[zb, b], Greater] -
FromDigits@Sort@IntegerDigits[zb, b], 15];
zb, {ss2, 1, n[[2]]}], 0];
Do[Print[{{Text[Style[d[[1]], Bold, Large]], Counts@Sort@k,
ListLinePlot[Tooltip@SortBy[Tally@k, First],
LabelingFunction -> (Callout[#1, Automatic] &),
PlotRange -> All, ImageSize -> Small]}, {Text[
Style[d[[2]], Bold, Large]], Counts@Sort@kb,
ListLinePlot[Tooltip@SortBy[Tally@kb, First],
LabelingFunction -> (Callout[#1, Automatic] &),
PlotRange -> All, ImageSize -> Small]}}[[fs]]], {fs, 1, 2}]
![i3][3]
Thus, samples were generated to be able to calculate all numbers with specific numbers of digits. In the example below, it was done with 3 and 4 digits simultaneously:
d1 = {3, 4}; b1 = 10; it1 = 15; it2 = 20;
z1 = {Range[FromDigits@PadRight[{1}, d1[[1]]],
FromDigits@Table[9, d1[[1]]]],
Range[FromDigits@PadRight[{1}, d1[[2]]],
FromDigits@Table[9, d1[[2]]]]};
Using the following code, we obtained the number of iterations necessary to reach the Kaprekar´s constants with 3 and 4 digits:
u1 = Sort@
Normal@Counts@
Table[z2 = z1[[1, t]];
e1 = Tally@
Table[Do[
z2 = FromDigits@Sort[IntegerDigits[z2, b1], Greater] -
FromDigits@Sort@IntegerDigits[z2, b1], 1]; z2, it1];
e10 = DeleteCases[
If[MemberQ[
Table[If[
ContainsOnly[
IntegerDigits[
e1[[x, 1]]], {IntegerDigits[e1[[x, 1]]][[1]]}] ==
True, {}, e1[[x]]], {x, 1, Length@e1}], {}] == True, {},
e1], {}]; e2 = CountsBy[e10, Last];
e3 = If[e2 == <||>, 0,
If[MemberQ[Keys@e2, 1] == False, 1, (1 /. e2) + 1]];
e3, {t, 1, Length@(z1[[1]])}]; u1b =
Sort@Normal@Counts@Table[z2b = z1[[2, t]];
e1b =
Tally@Table[
Do[z2b =
FromDigits@Sort[IntegerDigits[z2b, b1], Greater] -
FromDigits@Sort@IntegerDigits[z2b, b1], 1]; z2b, it2];
e10b = DeleteCases[
If[MemberQ[
Table[If[
ContainsOnly[
IntegerDigits[
e1b[[x, 1]]], {IntegerDigits[e1b[[x, 1]]][[1]]}] ==
True, {}, e1b[[x]]], {x, 1, Length@e1b}], {}] ==
True, {}, e1b], {}];
e2b = CountsBy[e10b, Last];
e3b =
If[e2b == <||>, 0,
If[MemberQ[Keys@e2b, 1] == False, 1, (1 /. e2b) + 1]];
e3b, {t, 1, Length@(z1[[2]])}]; v1 =
AssociationThread[
DeleteCases[Keys[u1], 0] -> (DeleteCases[Keys[u1], 0] /. u1)]; v1b =
AssociationThread[
DeleteCases[Keys[u1b], 0] -> (DeleteCases[Keys[u1b], 0] /. u1b)];
Do[Print[{ListLinePlot[Tooltip@v1,
LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &),
PlotLabel -> {Text[Style[d1[[1]], Large, Bold, Red]],
Text[Style[v1, Small]]}, PlotTheme -> "Marketing",
PlotRange -> All, ImageSize -> Large],
Grid[Join[{{Style["3 digits", Red, Bold]}, {Style["Steps", Bold],
Style["%Total", Bold]}},
Thread[{Range@5,
N[100*(Range@5 /. v1)/Total@(Range@5 /. v1), 4]}]],
Frame -> All],
ListLinePlot[Tooltip@v1b,
LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &),
PlotLabel -> {Text[Style[d1[[2]], Large, Bold, Red]],
Text[Style[v1b, Small]]}, PlotTheme -> "Marketing",
PlotRange -> All, ImageSize -> Large],
Grid[Join[{{Style["4 digits", Red, Bold]}, {Style["Steps", Bold],
Style["%Total", Bold]}},
Thread[{Range@7,
N[100*(Range@7 /. v1b)/Total@(Range@7 /. v1b), 4]}]],
Frame -> All]}], 1]
![i4][4]
- Test result of the method:
The Kaprekar constants for 3 and 4 digits were confirmed and, for 3 digits, the maximum number of iterations to converge is 5, while for 4 digits the maximum number of iterations to converge is 7. All proportions were shown in the result.
# Analysis for 5 and 6 digits:
Natural numbers with the number of digits equal to 5 and 6 form cycles as a result of the Kaprekar´s routine. Below is an example of a 5 digit random number showing its cycle (in this case, it took 5 iterations to start the cycle and the cycle has 4 terms):
![i5][5]
Do[Do[z =
FromDigits@Sort[IntegerDigits[z, b], Greater] -
FromDigits@Sort@IntegerDigits[z, b], 1]; Print[z], 15]
![i6][6]
Generating lists of all natural numbers with 5 and 6 digits (all 90000 and 900000 respectively), we find the result for the number of necessary iterations until the cycles start:
![i7][7]
The maximum number of iterations to start a cycle with the 5-digit numbers is 6 and the maximum number of iterations to start a cycle with the 6-digit numbers is 13.
The result, as a percentage, of the number of iterations for all 5 and 6 digit numbers:
![i8][8]
Using the following code, we have the number (and percentage) of terms that make up a cycle for all 5-digit numbers:
d1 = 5; b1 = 10; z1 =
Range[FromDigits@PadRight[{1}, d1], FromDigits@Table[9, d1]];
u1 = Table[it = 20; z2 = z1[[t]];
e1 = Tally@
Table[Do[
z2 = FromDigits@Sort[IntegerDigits[z2, b1], Greater] -
FromDigits@Sort@IntegerDigits[z2, b1], 1]; z2, it];
e10 = DeleteCases[
If[MemberQ[
Table[If[
ContainsOnly[
IntegerDigits[
e1[[x, 1]]], {IntegerDigits[e1[[x, 1]]][[1]]}] ==
True, {}, e1[[x]]], {x, 1, Length@e1}], {}] == True, {},
e1], {}];
Length@DeleteCases[e10, {_, 1}], {t, 1, Length@z1}];
x1 = Counts@Table[u1[[f]], {f, 1, Length@u1}]; kk1 =
AssociationThread[
DeleteCases[Keys[x1], 0] -> (DeleteCases[Keys[x1], 0] /. x1)];
Grid[Join[{{Style["5 digits", Bold, Red]}, {Style["Steps in Cycle",
Bold], Style["Value", Bold], Style["%Total", Bold]}},
Thread[{Keys@kk1, (Keys@kk1 /. kk1),
N[100*(Keys@kk1 /. kk1)/Total[Keys@kk1 /. kk1], 4]}]],
Frame -> All]
![i9][9]
For d1 = 6 (6-digit numbers), we have the number of terms in a cycle for 6-digit numbers. Where there is 1 term per cycle, it is where it converged in constants and this occurred in some of these numbers, that is, some numbers converged. The proportion of these numbers is also shown:
![i10][10]
Finally, to create the impression for 5 digits, I defined some iteration intervals (sections), multiples of 4 and 2, because they are the number of terms in 5-digit cycles (in this case, I used sections with 4 different iteration numbers: {20,21,22,23}) and each with all 90000 numbers with 5 digits.
d = 5; b = 10; n = 90000;
Do[k = DeleteCases[
Table[z =
Range[FromDigits@PadRight[{1}, d], FromDigits@Table[9, d]][[ss]];
Do[z =
FromDigits@Sort[IntegerDigits[z, b], Greater] -
FromDigits@Sort@IntegerDigits[z, b], f]; z, {ss, 1, n}], 0];
Print[{Text[Style[d, Bold, Large]], Text[Style[f, Bold, Red]],
SortBy[Tally@k, First]}], {f, {20, 21, 22, 23}}]
![i11][11]
Combining the values, we can cover the entire result for all the numbers in each term position in a cycle, finally showing the impression of the cycles generated from the 5-digit number.
r1 = {{53955, 844}, {59994, 2158}, {61974, 12680}, {62964,
11514}, {63954, 10946}, {71973, 5852}, {74943, 18194}, {75933,
10368}, {82962, 9776}, {83952, 7574}};
r2 = {{53955, 2158}, {59994, 844}, {61974, 10946}, {62964,
18194}, {63954, 10368}, {71973, 11514}, {74943, 7574}, {75933,
9776}, {82962, 12680}, {83952, 5852}};
r3 = {{53955, 844}, {59994, 2158}, {61974, 10368}, {62964,
7574}, {63954, 9776}, {71973, 18194}, {74943, 5852}, {75933,
12680}, {82962, 10946}, {83952, 11514}};
r4 = {{53955, 2158}, {59994, 844}, {61974, 9776}, {62964,
5852}, {63954, 12680}, {71973, 7574}, {74943, 11514}, {75933,
10946}, {82962, 10368}, {83952, 18194}};
vv = GatherBy[Flatten[{r1, r2, r3, r4}, 1], First];
uu = Table[{vv[[j]][[1, 1]],
Sum[vv[[j]][[i, 2]], {i, 1, Length@(vv[[j]])}]}, {j, 1,
Length@vv}];
ww = Table[uu[[g, 1]] -> uu[[g, 2]], {g, 1, Length@uu}];
Grid[Join[{{Style["5 digits", Bold, Red]}, {Style["Number", Bold],
Style["Quantity", Bold], Style["%Total", Bold]}},
Thread[{Keys@ww, (Keys@ww /. ww),
N[100*(Keys@ww /. ww)/Total[Keys@ww /. ww], 4]}]], Frame -> All]
ListLinePlot[Style[Tooltip@uu, Purple],
LabelingFunction -> (Callout[#1, Automatic, Scaled[1.5]] &),
Mesh -> Full, Filling -> Automatic, AxesStyle -> Directive[Red, 12],
PlotRange -> All, ImageSize -> Large]
![i12][12]
If we choose a random number with 5 digits and iterate until we form cycles, the chance of the result being in this proportion above is extremely high.
Likewise, to have the impression of cycles for numbers with 6 digits (d = 6, n = 900000, f(iter) = {30,31,32,33,34,35,36}), a number of sections multiple of 7 and 1 was generated for the iterations (I used 7 and each with all 900000 6-digit numbers, to cover all possible terms within a cycle). After using a code similar to the 5-digit code, the result below was generated for 6 digits and shows the impression of the cycles for that specific number of digits:
![i13][13]
# 7-digit analysis:
Below, we can see that, for numbers with 7 digits, the maximum number of iterations to form cycles using the Kaprekar´s routine is 13 steps (iterations) and the number of terms in the 7-digit cycle is always 8. The list of numbers was generated with the code similar to the ones already used.
![i14][14]
- Result (as a percentage) for all 7-digit numbers (note that there is no convergence to any Kaprekar constant using all 7-digit numbers):
![i15][15]
To generate the impression of cycles coming from numbers with 7 digits, I used a number of sections multiple of 8 (I used 8), because it is the number of terms in a cycle formed by this number of digits. Below is the impression (note that, for 7-digit numbers, the chance is perfectly equal to finding a term number for the cycle when executing the Kaprekar´s routine):
![i16][16]
# 8 digits:
There are 90000000 numbers with 8 digits. For my machine to be able to perform a task with this quantity of numbers (each number has 35 iterations in the code), I divided this total quantity into the 7 parts below:
d1 = 8; b1 = 10;
z0 = NumericArray[Range[10000000, 39999999], "UnsignedInteger32"];
z1 = NumericArray[Range[40000000, 49999999], "UnsignedInteger32"];
z1b = NumericArray[Range[50000000, 59999999], "UnsignedInteger32"];
z1c = NumericArray[Range[60000000, 69999999], "UnsignedInteger32"];
z1d = NumericArray[Range[70000000, 79999999], "UnsignedInteger32"];
z1e = NumericArray[Range[80000000, 89999999], "UnsignedInteger32"];
z1f = NumericArray[Range[90000000, 99999999], "UnsignedInteger32"];
I was able to calculate all numbers (with 8 digits) and the result was added below to provide how many iterations to reach a cycle, the number of terms in each cycle and the Kaprekar constants with 8 digits, using a code similar to the one already used. That´s the result:
![i17][17]
But, to have the impression of the cycle with numbers of 8 digits, it was not possible to do it in the same way as the previous ones, because it lacked computational power.
I had to do 21 sections with a certain number of iterations because the number of terms per cycle can be 3, 7 or 1, the smallest possible multiple of those numbers is 21. So, it would be 21 x 90000000. To get around this, I generated a sample well distributed using 21 x 1000000 random numbers with 8 digits as follows (f(iter) = {35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55}):
d = 8; b = 10;
Do[k = DeleteCases[
Table[z =
RandomInteger[{FromDigits@PadRight[{1}, d],
FromDigits@Table[9, d]}];
Do[z =
FromDigits@Sort[IntegerDigits[z, b], Greater] -
FromDigits@Sort@IntegerDigits[z, b], f]; z, 1000000], 0];
Print[{Text[Style[d, Bold, Large]], Text[Style[f, Bold, Red]],
SortBy[Tally@k, First]}], {f, {35, 36, 37, 38, 39, 40, 41, 42, 43,
44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55}}]
Combining the result from the 21 sections of iteration, I could see an outline of what the cycle impression would look like with 8 digit numbers. The values in the result are not exact because I used only 1.11% of the 90000000 at random in each of the 21 sections. Just so we can get an idea of what that impression looks like:
vv = GatherBy[
Flatten[{r35, r36, r37, r38, r39, r40, r41, r42, r43, r44, r45,
r46, r47, r48, r49, r50, r51, r52, r53, r54, r55}, 1], First];
uu = Table[{vv[[j]][[1, 1]],
Sum[vv[[j]][[i, 2]], {i, 1, Length@(vv[[j]])}]}, {j, 1,
Length@vv}];
ww = Table[uu[[g, 1]] -> uu[[g, 2]], {g, 1, Length@uu}];
Grid[Join[{{Style["8 digits(sample)", Bold, Red]}, {Style["Number",
Bold], Style["Quantity", Bold], Style["%Total", Bold]}},
Thread[{Keys@ww, (Keys@ww /. ww),
N[100*(Keys@ww /. ww)/Total[Keys@ww /. ww], 4]}]], Frame -> All]
ListLinePlot[{Style[{{4.0*10^7, 3.36*10^6}, {10*10^7, 3.36*10^6}},
Dashed, Red],
Style[{{4.0*10^7, 1.47*10^6}, {10*10^7, 1.47*10^6}}, Dashed, Red],
Style[Tooltip@uu, Green]}, Filling -> Automatic,
AxesStyle -> Directive[Red, 12], PlotRange -> All,
PlotLabel -> {"8 digits, random sample: 21 x 1000000 (1.11% Total, \
each iter section)"}, ImageSize -> Large]
![i18][18]
# Overall result:
The confirmation of the method of this work for the Kaprekar constants with 3 and 4 digits was true.
The 5, 6 and 7 digit study was a considered a success, as all numbers with this number of digits were used as sample, showing the probabilities after choosing a random number and after the Kaprekar´s routine arrives in a cycle.
It was confirmed that only a few 6-digit numbers generate two different Kaprekar constants and data on their proportions and chances were also found.
A satisfactory result was to have found two Kaprekar constants for some numbers with 8 digits, despite the great majority of the numbers having generated cycles. The proportions of iterations up to one cycle (max 19), the number of terms in one cycle and the proportions of the Kaprekar constant for 8 digits were successful, as all 90000000 numbers were used for these measurements. The graphic impression for the cycle for this number of digits was a partial success, as only a sample of numbers was used and not all as already discussed. Therefore, there are no precise values of their proportions in the final impression, just a graphic sketch of how it should be.
Perhaps one day with greater computational power, improved code, etc., I will be able to do this work with a greater number of digits (9, 10, etc.) and with greater precision in a large number of digits.
Thanks.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3732i1.png&userId=1316061
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9422i2.png&userId=1316061
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2072i3.png&userId=1316061
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6793i4.png&userId=1316061
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5393i5.png&userId=1316061
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3185i6.png&userId=1316061
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5604i7.png&userId=1316061
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1283i8.png&userId=1316061
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7805i9.png&userId=1316061
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3276i10.png&userId=1316061
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1169i11.png&userId=1316061
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8861i12.png&userId=1316061
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9640i13.png&userId=1316061
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3833i14.png&userId=1316061
[15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9658i15.png&userId=1316061
[16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8926i16.png&userId=1316061
[17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2569i17.png&userId=1316061
[18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10132i18.png&userId=1316061Claudio Chaib2020-01-29T16:11:03ZHandle issues in connection with GraphData for Cubic graphs?
https://community.wolfram.com/groups/-/m/t/1871799
Dear All,
I am really new in Mathematica, so every advice or answer is appreciated. I would like to examine the connection between the number of the vertices of a cubic graph and the diameter of the cubic graph.
As a first step I thought using GraphData["Cubic",n] would be a good idea. But if n=12 I get {Cubic,{12,91}}, {Cubic,{12,93}} and {Cubic, {12,94}} (besides another 91 graphs) which are not recognised as graphs by any other function in Mathematica (I also tried free form input). Did I make a mistake or what could go wrong? It would be important for me to find all cubic graphs for several ns.
And also if I use n=14 then there are 25 similar cases ({Cubic,{14,538}}, etc.). Is there a solution for this?
And last but not least for bigger ns GraphData gives only a few graphs but in theory there are thousands of such graphs. Are there any functions in Mathematica that provide the same results for bigger ns too? Or how are these ~20 graphs are selected by the function from the thousands of them?
Thank you for your answers and help in advance! Have a nice day!
Kind regards,
Zs. Sz.Zs Sz2020-02-03T16:53:45Z[WSC19] Exploring Lifetime Distributions for Nuclear Isotope Decay Cascades
https://community.wolfram.com/groups/-/m/t/1733124
![Bismuth-212 Decaying][1]
##Abstract##
The goal behind this project was to find a way to successfully showcase the processes behind nuclear decay reactions. Given an isotope, an algorithm was written to generate an automated interactive nuclear decay cascade chart with nodes to represent different isotopes. These nodes also provided the user with a method of visualizing the decay process by analyzing the selected isotopes' branching ratios with respect to half-life as seen above for example. Additionally, a chart was formed that provided information on all of the isotopes present in the nuclear decay cascade outputted. The user is able to use any known isotope compatible with Wolfram's [IsotopeData][2] function using [natural language inputs][3].
## I. Computing Ratios ##
The mathematical foundations of nuclear decay lie in the [Bateman equation][4], proposed and solved by physicists Ernest Rutherford and Harry Bateman respectively. This model utilizes a set of differential equations in order to calculate the shape of exponential graphs that represent how the parent isotope mass gets converted, whether that be for alternative decay modes or chain decays as seen below.
$$N_{D}={\frac {N_{1}(0)}{\lambda _{D}}}\sum _{i=1}^{D}\lambda _{i}c_{i}e^{-\lambda _{i}t}\text{ where } c_{i}=\prod _{j=1,i\neq j}^{D}{\frac {\lambda _{j}}{\lambda _{j}-\lambda _{i}}}$$
While this solution describes a chain reaction for an *n* amount of chain reactions in a row, the program only utilizes a more specific version to describe chain reactions for specifically two-decay chains: $$ {\frac {\mathrm {d} N_{B}}{\mathrm {d} t}}=-\lambda _{B}N_{B}+\lambda _{A}N_{A0}e^{-\lambda _{A}t}$$
For the alternate decay modes, I used a set of three equations to derive the correct ratios based on the parent isotope.
1. $N_{A}=N_{A0}e^{-\lambda t}$
2. $N_{B}=\frac{\lambda_B}{\lambda}N_{A0} \left(1-e^{-\lambda t} \right) $
3. $N_{C}={\frac {\lambda _{C}}{\lambda }}N_{A0}\left(1-e^{-\lambda t}\right) $, where $\lambda =\lambda _{B}+\lambda _{C}$.
I changed the units of the axes to create a more clear visualization that was in terms of percentages and number of half-lives rather than the number of atoms. Later, you can also notice how the branching ratios were used to construct the elegant lines displayed in the graphs.
halfLife[isotope_] :=
IsotopeData[isotope, "HalfLife"] // QuantityMagnitude;
decayConstant[isotope_] :=
Log[2.]/ IsotopeData[isotope, "HalfLife"] // QuantityMagnitude;
parentDecay[isotope_, t_] :=
If[halfLife[isotope] == Infinity, 1,
E^(-decayConstant[isotope] t*halfLife[isotope])]
parentDecay2[isotope1_Entity, t_] :=
If[(halfLife[isotope1] == Infinity), 1, E^(-Log[2] t)]
parentDecay4[isotope1_Entity, isotope2_Entity, isotope3_Entity,
isotope4_, t_] :=
If[(halfLife[isotope1] == Infinity), 1, E^(-Log[2] t)]
oneDecayA[isotope_, t_] :=
If[halfLife[isotope] == Infinity, 0,
1 - E^(-decayConstant[isotope] t*halfLife[isotope])]
oneDecayB[isotope1_, x_, t_] :=
IsotopeData[isotope1, "BranchingRatios"][[x]]*(1 - E^(-Log[2] t))
##II. Generating Graphics ##
There are three major decay patterns that are demonstrated in the program. The first one is one parent radionuclide decaying to two daughter nuclides, another is one parent radionuclide decaying to three daughter nuclides, and the final one models a nuclear decay. We can use the code for the second one as an example to show how the graphic is formed.
decayChart3[isotope_] := Manipulate[
Style[Row[{
Module[{
y = parentDecay2[isotope, NumberOfHalfLifes],
z = oneDecayB[isotope, 1, NumberOfHalfLifes],
w = oneDecayB[isotope, 2, NumberOfHalfLifes],
x = oneDecayB[isotope, 3, NumberOfHalfLifes]},
Plot[{
parentDecay2[isotope, t],
oneDecayB[isotope, 1, t],
oneDecayB[isotope, 2, t],
oneDecayB[isotope, 3, t]}, {t, 0, 10},
PlotRange -> {0, 1},
PlotLegends ->
Placed[{"Parent Isotope", "Child Isotope1", "Child Isotope2",
"Child Isotope3"}, Below],
Epilog -> {PointSize[Large], Point[{NumberOfHalfLifes, y}],
Point[{NumberOfHalfLifes, z}], Point[{NumberOfHalfLifes, w}],
Point[{NumberOfHalfLifes, x}]},
PlotLabel -> {"Parent Amount: " <> ToString@ (y*100) <> "%",
"Child1 Amount: " <> ToString@ (z*100) <> "%",
"Child2 Amount: " <> ToString@ (w*100) <> "%",
"Child3 Amount: " <> ToString@ (x*100) <> "%"},
ImageSize -> 500]],
blueList[[
Round[100*parentDecay2[isotope, NumberOfHalfLifes]] + 1]],
yellowList[[
Round[100*oneDecayB[isotope, 1, NumberOfHalfLifes]] + 1]],
purpleList[[
Round[100*oneDecayB[isotope, 2, NumberOfHalfLifes]] + 1]],
greenList[[
Round[100*oneDecayB[isotope, 3, NumberOfHalfLifes]] + 1]],
}],
ImageSizeMultipliers -> {0.34, 0.34}],
{NumberOfHalfLifes, 0, 10}]]
Here, we can see the code behind the plots. However, still, need to still generate the graphics that represent the masses behind each of the particles. The different colors represent the parent radionuclides and the daughter nuclides, with the protons and neutrons of the isotopes represented by a collection of spheres at the vertices of dodecaisocahdroncompounds in a three-dimensional volume.
vc = PolyhedronData["DodecahedronIcosahedronCompound", "Vertices"];
molecule1 = {RGBColor[0, 68, 105],
GraphicsComplex[#, Table[Sphere[i], {i, Length[#]}]]} &@vc;
molecule2 = {RGBColor[120, 48, 0],
GraphicsComplex[#, Table[Sphere[i], {i, Length[#]}]]} &@vc;
molecule3 = {Hue[0.81, 0.5, 0.84],
GraphicsComplex[#, Table[Sphere[i], {i, Length[#]}]]} &@vc;
molecule4 = {Hue[0.28, 0.85, 0.79],
GraphicsComplex[#, Table[Sphere[i], {i, Length[#]}]]} &@vc;
The shapes were then placed in these boxes at random. Because I chose to analyze the amounts in term of percentages, I made a list of 100 elements for each color, ranging from graphics with isotopes of each color in increments ranging to a hundred.
isotopeParent[x_] :=
Graphics3D[
Table[GeometricTransformation[#, transform[{0, 0, 0}]] &@
molecule1, x], Boxed -> False, PlotRange -> {-30, 30}];
isotopeChild[x_] :=
Graphics3D[
Table[GeometricTransformation[#, transform[{0, 0, 0}]] &@
molecule2, x], Boxed -> False, PlotRange -> {-30, 30}];
isotopePurple[x_] :=
Graphics3D[
Table[GeometricTransformation[#, transform[{0, 0, 0}]] &@
molecule3, x], Boxed -> False, PlotRange -> {-30, 30}];
isotopeGreen[x_] :=
Graphics3D[
Table[GeometricTransformation[#, transform[{0, 0, 0}]] &@
molecule4, x], Boxed -> False, PlotRange -> {-30, 30}];
Now, the plot generator will output the images correlating to the percentage at a given half-life. Using the example from before, the diagram for a one-parent to a three-child relationship can be modeled as seen below for Bismuth-212:
![enter image description here][5]
##III. Charts##
###Relation Graphs###
A relation graph can be used to represent the decay chains. This is because the Wolfram language has the ability to automatically construct charts that have vector connections with the parent isotopes and their respective child isotopes. Writing functions that utilize the Wolfram IsotopeData function helped to write functions that could be used by each node to identify the children isotopes.
DaughterNuclides[s_List] :=
DeleteCases[
Union[Apply[Join,
Map[IsotopeData[#, "DaughterNuclides"] &,
DeleteCases[s, _Missing]]]], _Missing];
ReachableNuclides[s_List] :=
FixedPoint[Union[Join[#, DaughterNuclides[#]]] &, s];
DaughterNuclidesQ[s1_, s2_] := (s1 =!= s2 && MemberQ[DaughterNuclides[{s1}], s2]);
children[x_Entity] := ReachableNuclides[{x}]
getSymbol[isotope_] := IsotopeData[isotope, "Symbol"]
decaySymbols[isotope_] := getSymbol[#] & /@ children[isotope]
Next, I created an autogenerating vertex label system which takes an isotope makes connections between different nodes.
makeVertexLabels[isotope_] :=
Table[children[isotope][[i]] -> decaySymbols[isotope][[i]], {i, 1,
Length@decaySymbols[isotope]}]
By combing these methods, the below function makes the decay chart with any given isotope in the Wolfram database.
RelationGraph[DaughterNuclidesQ, children[isotope],
Sequence[VertexLabels -> makeVertexLabels[isotope],
PlotRangePadding -> 0.65, ImageSize -> 300,
PlotTheme -> "Scientific"]]
###Information Chart###
The information chart works along with the relation tree in the same overall function. It is a table that uses the IsotopeData function to post decay statistics and type for all child isotopes of the parent molecule.
makeChart[isotope_] :=
Text[Grid[
Prepend[Table[
IsotopeData[#,
prop], {prop, {"Symbol", "HalfLife", "BindingEnergy",
"DecayModes"}}] & /@ children[isotope], {"symbol",
"half-life", "binding energy", "decay modes"}], Frame -> All,
Background -> {None, {{{LightBlue, White}}, {1 -> LightYellow}}}]]
The below function puts everything together and generates an output. We can use the Uranium-232 as an example isotope entity.
makeDecayGraphSample[isotope_] :=
Row[{RelationGraph[DaughterNuclidesQ, children[isotope],
Sequence[VertexLabels -> makeVertexLabels[isotope],
PlotRangePadding -> 0.65, ImageSize -> 300,
PlotTheme -> "Scientific"]], makeChart[isotope]}]
![enter image description here][6]
##IV. Button Integration##
The buttons at the place of the nodes serve to integrate part two with the rest of the program. I made a function that looks at each isotope and then decides what type of chart it should be used it depending on the number of children isotopes.
graphf[isotope_] :=
If[Length@DeleteMissing@IsotopeData[isotope, "DaughterNuclides"] ==
1, decayChart4[isotope],
If[Length@DeleteMissing@IsotopeData[isotope, "DaughterNuclides"] ==
2, decayChart2[isotope],
If[Length@DeleteMissing@IsotopeData[isotope, "DaughterNuclides"] ==
3, decayChart3[isotope],
Return[""]]]]
vertexGenerate[{xc_, yc_}, vertex_, {w_, h_}] :=
Inset[
Button[
vertex,
currentChart = graphf[vertex]],
{xc, yc}];
Using this, I modified the original relationship graph function to depict the updated *vertexGenerate* function to combine all the different sections of the code in one function.
makeDecayGraph[isotope_] := Module[{graph, currentChart = {}},
vertexGenerate[{xc_, yc_}, vertex_, {w_, h_}] :=
Inset[
Button[
vertex,
currentChart = graphf[vertex]],
{xc, yc}];
graph = RelationGraph[DaughterNuclidesQ, children[isotope],
Sequence[VertexLabels -> None,
PlotRangePadding -> 0.65, ImageSize -> 800,
PlotTheme -> "Scientific",
VertexShapeFunction -> vertexGenerate]];
Column[{graph, Dynamic[currentChart]}]
]
This resulted in a final output that, for demonstration, inputs the Uranium-232 isotope (with the Bismuth-212 button pressed).
![enter image description here][7]
##Future Extensions##
Some possible extensions that this program could have is making n-chain reaction functions. The program currently doesn’t fully exploit the differential recursive functions outlined in the Bateman model. This way, for any potential given chain process, all the successive decays would be calculated. The graphical representations of the decay shown with the molecules’ behavior over a certain number of half-lives could be updated to showcase a variety of more animations that help explain the behavior of the decay pattern.
###Github###
----------
[https://github.com/srangan24/WSS-Template][8]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bismut212.gif&userId=1725131
[2]: https://reference.wolfram.com/language/ref/IsotopeData.html
[3]: http://www.wolfram.com/language/fast-introduction-for-programmers/en/natural-language-input/
[4]: https://web-docs.gsi.de/~wolle/TELEKOLLEG/KERN/LECTURE/Fraser/L4.pdf
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at10.49.30AM.png&userId=1725131
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at7.43.48PM.png&userId=1725131
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at11.54.22AM.png&userId=1725131
[8]: https://github.com/srangan24/WSS-TemplateSrinath Rangan2019-07-12T01:53:33ZPlot the following custom function?
https://community.wolfram.com/groups/-/m/t/1878080
I am trying to plot this function with Plot3D and ContourPlot and they both give blank boxes. Is there something wrong with my code?
f[x_, y_] = 4*Sin[x - 2] + 4*Cos[y - 4] + 9*x^2 - 5*xy + 1*y^2 - 2*x + 4*ykatelyn crawford2020-02-14T01:45:06ZPlot the following expression according to the given constants?
https://community.wolfram.com/groups/-/m/t/1877881
I am trying to plot the following expression according to the given constants below; I got the plot. What I would like to see is something like fluctuated exponential decay; unfortunately, I couldn't be able to obtain. Could you please tell me if I missed something during or I suppose to introduce other techniques for plotting.
s = (m + 0.5)*(2*0.74)/(3*10^8);
R = 0.99981;
T = 1.9*10^-4;
L = 0.74;
c = 3*10^8;
tp = 50*10^-6;
td = 450*10^-6;
a = 0.00126;
Tau = 50*10^-9;
v = 30000;
vc = (3*10^8)/(2*0.74);
Plot[Sum[T^2 R^(2 m)* (UnitStep[tp - t + s]*a + UnitStep[t - s - tp] UnitStep[td - t + s] (1 - (1 - a) Exp[-((t - s - tp)/(2Tau))]) + UnitStep[ t - s - td] (a + (1 - a) Exp[-((t - s - td)/(2Tau))])) Abs[Exp[2 Pi*I*([v+ vc)*(t - s) + I*UnitStep[t - s - tp] UnitStep[td - t + s]*Pi]], {m, 0, 5000}], {t, 0, 0.0008}, PlotRange ->Mr Suma2020-02-13T14:03:13ZSolve a system of nonlinear differential equations?
https://community.wolfram.com/groups/-/m/t/1878247
I am trying to solve a system of differential equations but the following code instead of returning the solution returns an output that simply restates the system. Can anyone suggest how I should modify the code to solve the following system of equations:
x’’(t)=x’(t)* sqrt (x’(t)^2+y’(t)^2), y’’(t)=y’(t)* sqrt (x’(t)^2+y’(t)^2) -9.82
Initial conditions: y(0) = 0, x(0) = 0
system = {p''[x] == p'[x]*sqrt(p'[x]^2+q'[x]^2), q''[x] == q'[x]*sqrt(p'[x]^2+q'[x]^2)-9.82, p[0] == 0, q[0] ==0};
sol = DSolve[system, {p,q}, x]
Thank you for your help.Aleem Andrews2020-02-13T17:21:17ZLog Det vs Tr Log numerical discrepancy?
https://community.wolfram.com/groups/-/m/t/873767
Hello,
I was investigating the behaviour of Mathematica with matrices, and found the following very strange fact.
For the following matrix `V = 5 {{0.0030, 0.0008}, {0.0008, 0.0037}}` with some very nice `Eigenvalues[V] {0.0211161, 0.0123839}`
the two ways of calculation give very different results
`Log[Det[V]] // FullForm
-8.249076274459297
Tr[Log[V]] // FullForm
-8.189689624777785`
I wonder what is the nature of such huge discrepancy in whats should have been equal?Ignat Fialkovskiy2016-06-16T18:19:24Z[✓] Get number form of 1/e^-infinity ??
https://community.wolfram.com/groups/-/m/t/1877371
I have created function
Cend[x_]:=Limit[1/(e^(-x*n)+1),n->infinity]
and when I put -1 in it
it gives me
![enter image description here][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Annotation2020-02-12154238.png&userId=1877330
which should be 0.
I have tried //N, putting =and== in front, and seperating function and limits... but nothing helps me.
What should I do to get 0 from that??Youngsang Ji2020-02-12T21:46:45ZQuantum Simple Harmonic Oscillator - Matrix Approach
https://community.wolfram.com/groups/-/m/t/1877166
In[1]:= (* Basis states are Sqrt[2] Sin[n \[Pi] x]*)
bas[n_][x_] = Sqrt[2] Sin[n \[Pi] x];
In[2]:=
(* Basis states are normalized *)
FullSimplify[Integrate[bas[n][x]^2, {x, 0, 1}],
Assumptions -> n \[Element] Integers]
Out[2]= 1
In[3]:=
(* Basis states are 0 at x = 0 and x = 1 *)
Simplify[{bas[n][0], bas[n][1]},
Assumptions -> n \[Element] Integers]
Out[3]= {0, 0}
In[4]:= (* Hamiltonian operator is -\[HBar]^2/(2m)d^2/dx^2 + V(x). (\
\[HBar]^2/(2m)) is set equal to 1 and V(x) is set equal to v0 \
(x-1/2)^2 .
v0 will be large so that the boundary conditions at x = 0 and x = 1
will be a good approximation to the free simple harmonic oscillator *)
hamop = (v0 (x - 1/2)^2*#) - D[#, {x, 2}] &;
In[5]:= (* Hamiltonian matrix element between states m and n *)
ham[m_, n_] =
FullSimplify[Integrate[bas[m][x]*hamop @ bas[n][x], {x, 0, 1}],
Element[{m, n}, Integers]]
Out[5]= (4 (1 + (-1)^(m + n)) m n v0)/((m^2 - n^2)^2 \[Pi]^2)
In[6]:= (* Previous result is erroneous when m = n so this case is \
calculated separately *)
ham[n_, n_] =
FullSimplify[Integrate[bas[n][x]*hamop @ bas[n][x], {x, 0, 1}],
Element[n, Integers]]
Out[6]= n^2 \[Pi]^2 + v0/12 - v0/(2 n^2 \[Pi]^2)
In[7]:= (* Calculate a 100 x 100 Hamiltonian Matrix *)
AbsoluteTiming[
hamMatrix = Table[N @ ham[m, n], {m, 1, 100}, {n, 1, 100}];]
Out[7]= {0.0598937, Null}
In[8]:= (* Calculate the Eigensytem for the cae when v0 = 10^6 *)
AbsoluteTiming[res = Eigensystem[hamMatrix /. v0 -> 10^6];]
Out[8]= {0.0292793, Null}
In[9]:= (* The energy levels are in reverse order *)
ListPlot[res[[1, All]]]
![enter image description here][2]
In[10]:= (* Expected energy levels are (n + 1/2) \[HBar] \[Omega] = \
(n + 1/2) \[HBar] Sqrt[k/m]
where k is the "spring constant" in the equation and n = 0, 1, 2, etc.
k = 2 v0 since force is gradient of poential, so energy levels = (n + \
1/2) \[HBar] Sqrt[2 v0/m] = (n+1/2) Sqrt[2 v0] since \[HBar]^2/(2m) \
was set to 1 *)
In[11]:= Simplify[
Solve[{\[Delta]E == \[HBar] Sqrt[2 v0/m], (\[HBar]^2)/(2 m) ==
1}, {\[Delta]E, m}], Assumptions -> \[HBar] > 0]
Out[11]= {{\[Delta]E -> 2 Sqrt[v0], m -> \[HBar]^2/2}}
In[12]:= (* The energy levels are correct up to about the 50th energy \
level *)
ListPlot[Table[res[[1, -i]]/(2 10^3 (i - 1/2)), {i, 100}]]
![enter image description here][3]
(* Plot the first 20 lowest energy wavefunctions *)
Table[Plot[Sum[res[[2, -i, m]] bas[m][x], {m, 1, 100}], {x, 0, 1},
PlotRange -> All], {i, 20}]
![enter image description here][4]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9502plot1.jpg&userId=29126
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9502plot1.jpg&userId=29126
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8183plot2.jpg&userId=29126
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=plot3.jpg&userId=29126Frank Kampas2020-02-12T15:15:35ZGenerate a network for the entropy values
https://community.wolfram.com/groups/-/m/t/1835194
Dear all,
I calculated the entropy values for the time series of 44 cities. Is it possible to define a simple or complex network for these values? I attached a related reference for getting more information.
shannonEntropy[data_, binWidth_] :=
Module[{iter, n = Length[data], pi, pi1},
iter = {Min[data], Max[data] + binWidth, binWidth};
pi = N[BinCounts[data, iter]/n];
pi1 = DeleteCases[pi, 0.];
-pi1.Log[pi1]]
entr = {1.21`, 0.55`, 0.84`, 1.06`, 1.33`, 0.82`, 1.51`, 0.27`, 1.21`,
1.14`, 0.92`, 1.23`, 1.37`, 0.82`, 0.69`, 1.46`, 0.1`, 0.09`,
1.63`, 1.58`, 0.89`, 0.21`, 0.93`, 1.33`, 1.31`, 1.09`, 0.46`,
0.54`, 0.94`, 0.04`, 0.88`, 0.87`, 1.24`, 1.62`, 0.96`, 1.35`,
1.43`, 0.9`, 0.72`, 1.07`, 1.02`, 1.16`, 1.38`, 0.07`};
lat = {36.37`, 35.44`, 35.44`, 36.69`, 37.`, 35.75`, 36.69`, 34.81`,
36.06`, 36.69`, 35.13`, 36.37`, 36.37`, 34.81`, 33.56`, 37.`,
33.25`, 32.63`, 36.37`, 36.69`, 35.44`, 33.88`, 35.44`, 36.37`,
36.37`, 36.06`, 35.75`, 33.25`, 35.75`, 32.`, 35.73`, 35.75`,
34.81`, 36.06`, 35.13`, 37.`, 36.37`, 35.44`, 35.13`, 35.44`,
36.69`, 35.44`, 36.69`, 33.25`};
lon = {1.875`, 2.5`, -0.9375`, 3.125`, 7.8125`, 6.25`, 5.`, 5.625`,
4.6875`, 3.4375`, 4.0625`, 0.9375`, 6.5625`, 3.125`, 0.9375`,
8.125`, 6.875`, 3.75`, 7.5`, 5.625`, 7.1875`, 2.8125`, 0.3125`,
2.8125`, 6.25`, 0.`, 4.6875`, -0.3125`, -0.3125`, 5.625`, 7.3693`,
0.625`, 0.3125`, 5.3125`, -0.625`, 6.875`, 7.8125`,
7.8125`, -1.875`, 1.25`, 2.5`, 1.5625`, 3.75`, 5.9375`};Alex Teymouri2019-12-03T21:48:49ZIsolate integers in a pair from a table?
https://community.wolfram.com/groups/-/m/t/1876037
Evening,
I am trying to isolate the whole numbers/integers from a pair of numbers within a range. This is the function I am currently using:
Table[{Sqrt[1 + 5 k^2], Sqrt[k^2]}, {k, 0, 500}]
I want to find out which of the Sqrt(1+5k^2) is a square number itself, so a whole number. I am currently having to try a range and read through all my results. What I would like to to use a command, or a different command to the above, to just show those results that give me whole numbers.
I hope I have explained that well enough and am asking in the right place. Thank you in advance.Emily Larkin2020-02-10T18:50:42Z[✓] List of elements of a complex sequence
https://community.wolfram.com/groups/-/m/t/1875750
Hi all,
I am new to Mathematica but was wondering if it is possible to list complex (a+ib) elements of a sequence as a function of an element. For instance if I define a sequence recursively as x(k+1) = (1-i) x(k), can Mathematica display as output x(1)=(1-i) x(0); x(2)=(-2i) x(0); x(3)= -2(1+i) x(0); x(4)=-4 x(0); etc. ? If it is possible, how ? What would be the best way to plot the result ?
Thanks !Al Gorgeous2020-02-10T09:48:16ZFind a function with a known gradient?
https://community.wolfram.com/groups/-/m/t/1875368
Hello. How do I find a function with a known gradient? The problem I am trying to solve is in the attached file.Meryem Aslı2020-02-09T12:19:41Z