Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by active[GIF] Circle Back (Stereographic recursive circle packing)
http://community.wolfram.com/groups/-/m/t/1168171
![Stereographic recursive circle packing][1]
**Circle Back**
This is somewhat in the same spirit as [_Pack It In_][2] and [_Eyes Wide_][3], in that it shows the stereographic projection of a collection of non-overlapping circles on the sphere. In this case, though, it's an infinite family of circles on the sphere (though of course I'm only showing a finite subcollection).
This family is defined recursively, starting from 16 equally-spaced points on the equator: each is the center of a circle of (spherical) radius $\pi/16$ (i.e., half the distance between adjacent points). Next, I want to put 16 equally-spaced points on a circle of longitude in the northern hemisphere so that the circles centered at those points which are just tangent will also be tangent to the corresponding circles from the previous iteration.
Now, the spherical distance between $n$ equally-spaced points at height $z$ is given by
FullSimplify[
VectorAngle[{Sqrt[1 - z^2] 1, 0, z}, {Sqrt[1 - z^2] Cos[2 π/n], Sqrt[1 - z^2] Sin[2 π/n], z}],
z ∈ Reals && -1 < z < 1 && n ∈ Integers && n >= 2]
which comes out to be $\arccos\left(z^2-\left(z^2-1\right) \cos \left(\frac{2 \pi }{n}\right)\right)$. So we want to work out when half of that quantity (the radius of the circles on the second row) plus $\pi/16$ (the radius of the circles on the first row) is equal to the distance between points on the first row and the corresponding point on the second row.
For each successive row we do the same computation, so we can recursively compute the correct $z$-values of the rows up to level $k$ using `NestList[]`:
NestList[
Re[x] /.
FindRoot[
ArcCos[#^2 - (-1 + #^2) Cos[(2 π)/n]]/2 +
1/2 ArcCos[x^2 - (-1 + x^2) Cos[(2 π)/n]] ==
VectorAngle[{Sqrt[1 - x^2], 0, x}, {Sqrt[1 - #^2], 0, #}],
{x, 1}] &,
0, k]
So now we can put it all together (to produce a not-completely-unresponsive `Manipulate`, I use `depth = 6` in the below code, which leaves big gaps near the poles of the sphere; for the final animation I used `depth = 16`):
DynamicModule[{p, b, n = 16, depth = 6, zList, verts,
cols = RGBColor /@ {"#14FFEC", "#323232"}},
zList = NestList[
Re[x] /.
FindRoot[
ArcCos[#^2 - (-1 + #^2) Cos[(2 π)/n]]/2 +
1/2 ArcCos[x^2 - (-1 + x^2) Cos[(2 π)/n]] ==
VectorAngle[{Sqrt[1 - x^2], 0, x}, {Sqrt[1 - #^2], 0, #}],
{x, 1}] &,
0, depth];
verts = Flatten[
Table[
{Sqrt[1 - zList[[i]]^2] Cos[s + π/n], Sqrt[1 - zList[[i]]^2] Sin[s + π/n], sgn*zList[[i]]},
{i, 1, Length[zList]}, {sgn, {-1, 1}}, {s, 2. π/n, 2 π, 2 π/n}],
2];
Manipulate[
p = verts.RotationMatrix[-θ, {1, -1, 0}];
b = NullSpace[{#}] & /@ p;
Graphics[
{EdgeForm[None],
Table[
{cols[[1]],
Polygon[
Table[
With[{t = ArcCos[verts[[i, 3]]^2 - (-1 + verts[[i, 3]]^2) Cos[(2 π)/n]]},
Stereo[
Cos[t/2] p[[i]] + Sin[t/2] (Cos[s] b[[i, 1]] + Sin[s] b[[i, 2]])]],
{s, 0., 2 π, 2 π/200}]]},
{i, 1, Length[p]}]},
PlotRange -> 3.5, Background -> cols[[-1]], ImageSize -> 540],
{θ, 0, π}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dots8c.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1166591
[3]: http://community.wolfram.com/groups/-/m/t/1167789Clayton Shonkwiler2017-08-23T04:35:42ZSSD1306-OLED module driver for RaspberryPI
http://community.wolfram.com/groups/-/m/t/1168389
SSD1306 OLED module driver for RaspberryPi was developed. I2c 128x32 display module driver was written on Mathematica and i2c utility. An OLED 123x32 display module is very handy and cute for RaspberryPI, however, we can get only display drivers written with Python. Developed driver uses RaspberryPI system utility for I2C and the Mathematica code, because the Mathematica I2c driver doesn't work on my RaspberryPi unfortunately.
![enter image description here][1]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2017-08-2219.11.55.jpg&userId=897049Hirokazu Kobayashi2017-08-22T10:51:03ZPlot 3D fractal tree?
http://community.wolfram.com/groups/-/m/t/1168243
Searching in the web for information about the affine transformation, I found the one page, which called my attention for the tree that show and is this
![tree][1]
but unfortunately do not give information about the algorithm to create it, I would like to ask help to make one the same or very similar, maybe someone knows where to get more information about it. Thanks in advance, here is the [link to the page][2] mentioned above
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=arbol.jpg&userId=133435
[2]: https://hiveminer.com/Tags/binary,tree/InterestingLuis Ledesma2017-08-22T03:12:55Z[✓] Plot in 3D a X-zylo ?
http://community.wolfram.com/groups/-/m/t/1165290
X-zylo is a simple cylindrical object with Sine(Sin[t]) shaped undulation on top.
You can find link below. It's a flying gyroscope.
https://www.amazon.com/X-Zylo-X-zylo-Flying-Gyroscope/dp/B0069G6CKG
How can I make this? (cylindrical parametric function? Just bending/flexing the Sin[t], {t,0,10Pi} in 360 degree)
Plot3D
ParametricPlot3D
RevolutionPlot3D
in any form to make it..
Thank in advance!Donghwan Roh2017-08-15T11:44:15ZPlace text in 3D graphics, so that it does not move when reoriented?
http://community.wolfram.com/groups/-/m/t/1168097
Often I would like to place some text in a 3D graphic, so that it does not move when the graphic is reoriented.
I have several hacks to do this but it would be nice if this were a standard option in the Graphics3D input.S M Blinder2017-08-22T00:52:04Z[✓]Define sinc[x_]:=Piecewise[{{Sin[Pi x]/(Pi x), {x != 0}},{1, {x == 0}}}]
http://community.wolfram.com/groups/-/m/t/1167799
Hello everyone. I tried to define the following function:
sinc[x_]:=Piecewise[{{Sin[Pi x]/(Pi x), {x != 0}}, {1, {x == 0}}}]
but, when I plot it, the figure is empty. Why and how can I fix this problem?
Plot[sinc[x], {x, -5, 5}]
Thank you for your time.Gennaro Arguzzi2017-08-21T08:32:10Z[✓] Use Plot inside a Manipulate?
http://community.wolfram.com/groups/-/m/t/1167963
The following plots just fine
Plot[x^2+3x-5,{x,-5,2}]
When I however try and use manipulate the graph does not show:
Manipulate[Plot[x^2+ax-5,{x,-5,2}],{a,-3,3}]
(The axis display with the slider but nothing else)
https://www.wolframcloud.com/objects/da6fba56-868d-4637-b2d3-88a6efa03aa6
What am I doing wrong?Andre Basel2017-08-21T09:09:13Z[GIF] Eyes Wide (Stereographic projection of spherical circle packing)
http://community.wolfram.com/groups/-/m/t/1167789
![Stereographic projection of optimal circle packing of the sphere by five circles][1]
**Eyes Wide**
Very much in the same spirit as [_Pack It In_][2], this shows the stereographic image of the optimal packing of the sphere by five circles. The circles are centered at the (normalized) vertices of the triangular bipyramid.
The coloration is misleading, in that the five circles _are_ partitioned into a group of three (the three centered on points $120^\circ$ apart on the equator) and a group of two (the two centered on the north and south poles), but the colors don't match up with those groupings. The two blue circles are two of the three circles centered on the equator; the third is the one circle that doesn't touch those two blue circles.
Anyway, here's the code:
Stereo[p_] := Most[p]/(1 - Last[p]);
DynamicModule[{p, b, t = π/4.,
verts =
RotationTransform[π/6, {0, 0, 1}][Normalize[N[#]]] & /@ PolyhedronData[{"Dipyramid", 3}, "VertexCoordinates"],
cols = RGBColor /@ {"#B91372", "#41EAD4", "#011627"}},
Manipulate[
p = verts.RotationMatrix[-θ, {1, 0, 0}];
b = Orthogonalize[NullSpace[{#}]] & /@ p;
Graphics[
{FaceForm[None],
Table[
{EdgeForm[
Directive[Thickness[.0075], cols[[Mod[Ceiling[i/3], 2, 1]]]]],
Polygon[Table[Stereo[Cos[t] p[[i]] + Sin[t] (Cos[s] b[[i, 1]] + Sin[s] b[[i, 2]])], {s, 0, 2 π, 2 π/200}]]},
{i, 1, Length[verts]}]},
PlotRange -> 5, Background -> cols[[-1]], ImageSize -> 540],
{θ, 0, 2 π}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=packing12tc.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1166591Clayton Shonkwiler2017-08-21T04:45:07ZBuild a Zero Tree/Quad Tree on the output of a CDFWavelet[] Transform?
http://community.wolfram.com/groups/-/m/t/1167553
Hi, I have noticed that there is no way to get subband decompositions out of the `DiscreeteWaveletTransform[]` with `CDFWavelet[]` that is of size a power of two. For example, consider the following code fragment:
data = RandomReal[{0, 1}, {16, 16}];
dwd = DiscreteWaveletTransform[data, CDFWavelet[]];
dwd["Dimensions"]
(*output*)
{{0} -> {12, 12}, {1} -> {12, 12}, {2} -> {12, 12}, {3} -> {12,
12}, {0, 0} -> {10, 10}, {0, 1} -> {10, 10}, {0, 2} -> {10,
10}, {0, 3} -> {10, 10}, {0, 0, 0} -> {9, 9}, {0, 0, 1} -> {9,
9}, {0, 0, 2} -> {9, 9}, {0, 0, 3} -> {9, 9}, {0, 0, 0, 0} -> {9,
9}, {0, 0, 0, 1} -> {9, 9}, {0, 0, 0, 2} -> {9, 9}, {0, 0, 0,
3} -> {9, 9}}
Giving, for example, a first level composition of LH detail coefficients of dimension 12 by 12 (instead of 8 by 8). This presents a problem for my application (image compression using zero trees/quad trees). The coefficient matrices should be a power of two sizes to construct quad trees across subbands. A quad tree is parent-child dependency tree between pixels that have the same orientation across wavelet decomposition subbands. Mostly each node in a coarse level has four child nodes in the next finer level at the same spatial position.
Is there a way to produce appropriately sized wavelet decompositions? I know MATLAB can do so using periodic extension mode for dwt2 function. What is a possible equivalent in Mathematica?Hamood Khan2017-08-20T19:30:35Z[GIF] Pack It In (Stereographic projection of circles)
http://community.wolfram.com/groups/-/m/t/1166591
![Stereographic projection of circles centered at cube vertices][1]
**Pack It In**
Consider the eight vertices of the cube as points on the unit sphere, then make (spherical) circles centered on those points with radii chosen so that the circles are just tangent. Then this gives a packing of the sphere by 8 circles of (spherical) radius $\frac{1}{2} \arccos \left(\frac{1}{3}\right) \approx 0.61548$. (Of course, this is not the optimal packing by 8 circles; that is given by circles centered on the vertices of the square antiprism.)
Now, rotate the sphere and the eight circles around the $x$-axis and stereographically project down to the plane. After adding some color, the result is this animation.
Here's the code:
Stereo[{x_, y_, z_}] := 1/(1 - z) {x, y};
DynamicModule[{p, b,
verts = Normalize /@ PolyhedronData["Cube", "VertexCoordinates"],
t = 1/2 ArcCos[1/3],
cols = RGBColor /@ {"#EF6C35", "#2BB3C0", "#161C2E"}},
Manipulate[
p = RotationMatrix[θ, {1, 0, 0}].# & /@ verts;
b = Orthogonalize[NullSpace[{#}]] & /@ p;
Graphics[{EdgeForm[None],
Table[{cols[[Floor[(i - 1)/4] + 1]],
Polygon[Table[Stereo[Cos[t] p[[i]] + Sin[t] (Cos[s] b[[i, 1]] + Sin[s] b[[i, 2]])], {s, 0, 2 π, 2 π/200}]]},
{i, 1, Length[verts]}]}, PlotRange -> Sqrt[6],
Background -> cols[[-1]], ImageSize -> 540],
{θ, 0, π/2}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=packing5.gif&userId=610054Clayton Shonkwiler2017-08-17T21:46:10ZHow to "cheat" on Flash games using Mathematica
http://community.wolfram.com/groups/-/m/t/1166766
A friend of mine has shown to me this Facebook game, 8 ball pool. I particularly don't like playing games, and this pool game has a prediction-line for the balls (which I find it kind of a cheat, since real life pool there no guides). And I thought to myself it I could concoct some code to extend the prediction-line to improve aiming, just as a fun exercise (which in itself is more enjoyable to play the actual game).
Image below shown the extend lines.
![enter image description here][1]
And the code:
This part is for positioning. I open the Facebook page in one screen while the other one has Mathematica.
![enter image description here][2]
This part is basically cropping the screenshot, making it black-and-white, finding the cue ball and the prediction-line and overlaying it on top of the original image.
![enter image description here][3]
This part dynamically takes screenshots and output the overlay image, which is the first image shown in this post.
![enter image description here][4]
## Disclaimer ##
Although I don't find this type of thing cheating per se since you can achieve basically the same thing putting a ruler on your PC or phone.
But I would advise against cheating on games only on the grounds that it makes the game less fun (that's why I put the code as images and I'm in no way responsible for your use of this code.). This post is only to show another side of Mathematica; with a few minutes of programming, it was possible to "cheat" in a game fairly easily (but buggy-ly).
A better application of this would be to use an NN to play games, training an AI, etc (although the crude application of capturing the screen is a huge bottleneck...)
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Capture16.png&userId=845022
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2017-08-17_222251.png&userId=845022
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2017-08-17_222300.png&userId=845022
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2017-08-17_222313.png&userId=845022Thales Fernandes2017-08-18T01:39:54Z[WMP17] Convert Pixel Image into Vector Graphics
http://community.wolfram.com/groups/-/m/t/1160838
As part of my Wolfram Mentorship Program, I chose to work on this interesting and challenging project that combines image processing, artificial intelligence, graph theory and Wolfram Language (who can think of better combination?!). Now since part of the work is confidential and can't be shared (as it uses some of internal WL code), it's useful to mention that this post is not intended to be a full step by step tutorial but rather a conceptual overview on what we are working on. Hope you'll enjoy it and find it useful !
## Project Description ##
Write a function to find an approximation to images as vector graphics (effectively: "convert GIF to SVG'). Flags may be a helpful example to consider. There will be a tradeoff between "fitting' the image, and having a simple "model' in terms of vector graphics.
Category: Algorithms, Artificial Intelligence
Suggested readings:
- http://reference.wolfram.com/language/guide/ImageProcessing.html
- http://reference.wolfram.com/language/ref/Interpolation.html
-------
## Introduction ##
Two typical representations for pictures are raster images and vector graphics. Images are represented by an array of picture-elements called pixels, each has a numerical value to indicate its color. Pixel based image representation has revealed its drawbacks in many applications such as image magnification and printing. Vector graphics defines images using graphics objects like curves and surfaces, rather than discrete points of pixels. The vector representation has many interesting features; such as being scalable, compact and resolution independent.
Conversion between pixel images and vector graphics is always desired. The conversion from vectors to images in WL is straightforward using Rasterize function. However, the opposite is surprisingly not easy at all and has attracted increasing interest in recent years. The following figure illustrates some possible issues in reconstructing line edges and surface colors from an image.
![Possible issues with ImageGraphics[] function][1]
-------
## Approach ##
The conversion process, in general, is divided into three stages: first of all, edge detection is performed to highlight image outline, the result is chain of pixels. Actually, not all those pixels are necessary to reconstruct original image, so a feature extraction stage is required to keep only important pixels (edges, corners, etc.). Finally, the key points are connected together to form graphics lines & meshes, as shown below, to reconstruct image outlines & surface colors. The following figure illustrate these stages:
![Conversion from Raster Image to Vector Graphics][2]
The scope of this post covers converting line drawing images to vector graphics (i.e. reconstructing shape outline only without surface color).
Image to graph
--
It is convenient to use graph object as an intermediate representation of image features, where key points represents graph nodes and image lines are graph links. Once the graph is constructed, it will be easy to replace graph links with the actual curve shape. A good starting point could be from *MorphologicalGraph* functions starting with skeleton image (e.g. ![skeleton image][3] which is the result of *Binarize* and *Thinning* functions applied to the input image). Then modify graph links to have the exact shape of original image.
The process is divided into three steps:
1. Convert image into list of vertices and links
2. Find connection between vertices and links
3. Find edges
**Feature Extraction (Vertices & Links)**
In the first step, we use *SkeletonEndPoints* and *SkeletonBranchPoints* as feature points. They will serve as graph's edges, which will define the shape of our vector graphics. Each vertex is given a unique index as shown below. I tested the function on a simple image, with 3 endpoints and 1 branch point (I should have included a loop for completeness). Each node has given a unique index (I marked vertices in yellow for better visualization). One tricky situation is when we have a circle (or any isolated loop) that doesn't contain any branch. in this case, *MorphologicalTransform* will return an empty result, so we should think of something else. I found *ImageCorners* pretty useful, but it return (x,y)-coordinates instead on (row,column)-pairs. So you need to convert them first before producing an image that can be added with *ImageAdd* to the vertices.
findVertices[skeleton_, opt : OptionsPattern[Graph]] := Module[
{vertices, others},
vertices = ImageAdd[
MorphologicalTransform[skeleton, "SkeletonEndPoints", Padding -> 0],
MorphologicalTransform[skeleton, "SkeletonBranchPoints", Padding -> 0]];
{vertices, others}
];
The result of this function is shown below.
![vertices][4]
Subtracting vertices from the image produces line segments. Those are the links that will connect graph edges. They will be fed to the simplification algorithm in the next stage. Note that each link is given a unique index among links and vertices. Number of segments as well as the length of each segment is also measured.
findLinks[skeleton_, vertices_, vertexCount_] := Module[
{dims = ImageDimensions[skeleton], linkComponents, others},
linkComponents = MorphologicalComponents@ImageSubtract[skeleton, vertices];
linkComponents = Replace[linkComponents, Except[0, n_] :> n + vertexCount, {2}];
{linkComponents, others}
]
![links][5]
**Features to Graph (Links and Nodes)**
The second step is by far the most involving step in the whole process; finding which vertex is connected to which link. Connection can be strong (from four directions) or weak (also include diagonals). There is also some special cases like finding short connections that consist of only 2 pixels, etc.A good starting point is from *ComponentMeasurements* by measuring *"Neighbors"* of vertices and links. To find strong connections you can set *CornerNeighbors* to *False*, while setting it to *True* yields weak connections. A sample output is shown below.
![Strong Connections][6] ![Weak Connections][7]
Note that point 4 and link 6 are strongly-connected. Point 2 is clearly a branch point since it is connected to three links (5,6,7). Now without further details of internal subfunctions involved in this step, I'll show the general function to give you an idea on how complex this step is.
Options[morphologicalGraphics] = Options[Graph];
morphologicalGraphics[skeleton_, opts : OptionsPattern[morphologicalGraphics]] := Module[
{vertices, vertexComponents, linkComponents, strong4, weak8,
redundantEdges, directEdges, linkedEdges, loopEdges, cleanEdges, extraEdges, allEdges, allLines},
{vertices, others} = findVertices[skeleton];
{linkComponents, others} = findLinks[skeleton, vertices, otehrs];
{strong4, others} = findStrongConnections[vertexComponents, linkComponents, others];
{weak8, others} = findWeakConnections[vertexComponents, linkComponents, others];
redundantEdges = findRedundantEdges[strong4, others];
{directEdges, linkedEdges, loopEdges, cleanEdges} = findEdges[weak8,redundantEdges, others];
{extraEdges, others} = findExtraEdges[strong4, linkComponents, weak8, others];
(* convert all edges into list of points *)
allLines = Join[
Replace[List @@@ directEdges, Dispatch@vertexCoordinates, {2}],
Replace[Join[List @@@ cleanEdges, List @@@ extraEdges], Dispatch@Join[vertexCoordinates, linkPositions], {2}]
]
];
The final output of the graph is converted to a list of coordinates defining the lines in the original image. Those points are not necessarily listed in the correct order. Furthermore, not all the points are needed to reproduce the lines segment. This allows more room for line simplification process (next stage) which result in smoother vector graphics, as well as smaller file size.
The following code is to test *morphologicalGraphics* function we show above.
Framed@Module[{x},
x = morphologicalGraphics[skeleton];
Image[skeleton, ImageSize -> Small] ->
Graphics[{Line[x], Red, PointSize[0.03], Point /@ x, Blue,
Point[Join[First /@ x, Last /@ x]]},
PlotLabel -> "Blue edges are correct, \nred points are not in the correct order", ImageSize -> 250]
]
![Result of morphologicalGraphics][8]
----------
## Line Simplefication ##
Douglas-Peucker algorithm is used to simplify curves and lines connecting graph edges (called polylines). Simplification in this context refers to reducing the number of points needed to draw a polyline while maintaining its basic shape. The algorithm assumes points connecting two edges to be in right order (this step is done in *pointsToPath* function). This process is divided into two steps:
1. Rearrange list of points
2. Simplify line segments
**Rearrange points as Path**
In the first step, we'll benefits from the intermediate representation we have. Since we convert raster image into a graph of nodes and links, we can use graph theory to rearrange list of points we have by creating a *DelaunayMesh* then trace the shortest path from the start to the end using *FindHamiltonianPath*.
Two special cases are there: 1) when a starting point meets the end point we have a loop and FindHamiltonianPath fails to find shortest path. One possible solution is by using *FindHamiltonianCycle*. 2) if by any chance we had all points aligned in a straight line, *DelaunayMesh* produces an empty region (since points are aligned in 1D). In this case we simply use *Sort* on the points we have. The following code illustrates this step.
pointsToPath[points2_List] := Module[
{a, b, points, Region, edges, graph, path},
points = points2;
(* Loop detection :TODO:need enhancement using FindHamiltonianCycle *)
If[points[[1]] == points[[-1]],
points = Drop[points, -1];
{a, b} = TakeDrop[points, {Position[points, Last@Nearest[points, points[[1]], 2]][[1, 1]]}];
points = Join[b, a];
];
(* Create a Delaunay mesh *)
Region = DelaunayMesh[points];
If[Region === EmptyRegion[2], Return[Sort@points]];
(* Mesh to graph *)
edges = Map[Sort, MeshCells[Region, 1][[All, 1]]];
graph = Graph[Range[Max@edges], Apply[UndirectedEdge, edges, {1}],
EdgeWeight -> Map[EuclideanDistance @@ points[[#]] &, edges]];
path = FindHamiltonianPath[graph, 1, Length[points]];
Part[points, path]
]
And here is the result.
![rearranged points][9]
**Simplification Step.**
Once the points are in the correct order, we can apply Douglas-Peucker algorithm. Refer to the previous figure, the algorithm will not change blue points (edges), it will simplify red points (segment points) to reconstruct curves that connect blue points with minimum number of red points. The process works as follow:
First, Connect two edges (p1, p2) with line segment and measure distance between all intermediate points (qi) and this line.
pointLineDistance[q_, {p1_, p2_}] := With[
{eqn = (q - p1).(p2 - p1) / (p2 - p1).(p2 - p1)},
Which[
eqn <= 0 , Norm[q - p1],
eqn >= 1 , Norm[q - p2],
True , Norm[q - (p1 + eqn (p2 - p1))]
]
];
Then, if the distance to the furthest point is greater than threshold (smoothness factor), pick it as a new edge and split line into two segments. Otherwise, the segmentation process is done and all other intermediate points can be eliminated.
lineSplit[segment[points_List], threshold_] := Module[
{dists, dmax = 0, pos},
dists = Map[pointLineDistance[#, {points[[1]], points[[-1]]}] &, points[[2 ;; -2]]];
dmax = Max[dists];
If[dmax > threshold,
pos = Position[dists, dmax][[1, 1]] + 1;
{segment[points[[1 ;; pos]]], segment[points[[pos ;;]]]},
segment[points, done]
]
] /; Length[points] > 2
lineSplit[segment[points_List], threshold_] := segment[points, done];
lineSplit[segment[points_List, done], threshold_] := segment[points, done];
Finally, recursively apply segmentation process using *ReplaceRepeated* until all segments are marked *done*. Note that I used *First/@First/@ ...* to access data points in the structure *segment[{points,_}, _]* which is used by *lineSplit* function.
simplifyPolyline[points_List, threshold_] :=
Append[First /@ First /@ Flatten[
ReplaceRepeated[{segment[points]},
s_segment :> lineSplit[s, threshold]]
], Last[points]
];
A simple example illustrates the simplification process is shown bellow. For better approximating curvy shapes, line segments can be used as supporting lines for *BSpline* curves.
![line simplification][10]
----------
## SketchGraphics Function ##
Finally, we are ready to rap everything up in a nice and compact function. As we described in the far beginning, the function accepts a raster line drawing image (skeleton) and produces a vector graphics after converting image into graph then simplify links between nodes.
sketchGraphics[skeleton_Image, polyline_, smoothness_,
opts : OptionsPattern[Graph]] := Module[
{allLines, allPaths},
allLines = morphologicalGraphics[skeleton];
allPaths = Map[ simplifyPolyline[#, smoothness] &,
pointsToPath[#] & /@ allLines];
Graphics[polyline /@ allPaths, Sequence @@ Flatten@{opts}]
];
And here we are. Left: input, Right: output.
![final result][11]
----------
## More Tests ##
![Test 1 PNG][12] == ![Test 1 SVG][13]
![Test 2 PNG][14] == ![Test 2 SVG][15]
![Test 3 PNG][16] == ![Test 3 SVG][17]
![Test 4 PNG][18] == ![Test 4 SVG][19]
![Test 5 PNG][20] == ![Test 5 SVG][21]
![Test 6 PNG][22] == ![Test 6 SVG][23]
----------
## Technical Notes ##
- **Using ImageCorners**:
I mentioned that using this function can help solving loop problem when no branch or endpoint is found. However, some processing is needed before you can add it to vertices image. *ImageCorners* processes list of graphics coordinates (x,y), so you'll need to convert it to matrix coordinates (row, column) then to binary image. The following code is one way to do that (I guess there should be a better way to get rid of the *For-loop*):
vertices = Transpose@ConstantArray[0, ImageDimensions[skeleton]];
height = Last@ImageDimensions[skeleton];
vertexCoordinates = ImageCorners[skeleton, 1, 0.001, 2];
{row, col} = IntegerPart@Apply[{height - (#2 - .5), #1 + .5} &, vertexCoordinates, {1}] // Transpose;
For[i = 1, i <= Length[vertexCoordinates], i++,
vertices[[ row[[i]], col[[i]] ]] = 1;
];
Image[vertices]
![coordinate systems][24]
- **More details on *pointsToPath* function**
In the simplification step, we are required to make sure that points in a line segment are in the correct order so that we can use Douglas-Peucker algorithm. This step involves two operations: constructing a Delaunay mesh and then Finding the Hamiltonian path. the following three figures shows (from left to right) list of points, distorted graphics object, sorted point on the mesh.
![Point to Path][25]
- **From Image to Graphics:**
In case you'd like to see how I created the following illustration, here is the code from Electromagnetics Package
![Conversion from Raster Image to Vector Graphics][26]
<< NDSolve`FEM`;
img[size_] := ColorNegate@Binarize@Rasterize[Style["Hi", size]];
{{
ArrayPlot[
pimg = ReplacePart[
MorphologicalComponents[img[20]], {5, 19} -> 1], Mesh -> All,
ImageSize -> Small, PlotLabel -> "Pixel Image",
ColorRules -> {0 -> White, 1 -> Red, 2 -> Green, 3 -> Blue}],
cimg = ImageCorners[img[700], 0.5];
HighlightImage[ColorNegate@Thinning[EdgeDetect@img[700]],
{PointSize[0.03], Green,
Point /@ cimg[[{1, 2, 13, 14, 3, 4, 20, 19, 9, 8, 18, 17, 1}]],
Blue, cimg[[{5, 6, 16, 11, 22, 21, 10, 15, 7, 12, 5}]],
Red, cimg[[23 ;; -1 ;; 3]]},
ImageSize -> Small, PlotLabel -> "Points to Graphics Lines"],
}, {
toMesh[poly_, color_] :=
MeshRegion[
ToElementMesh[poly, MaxCellMeasure -> 570, AccuracyGoal -> .125],
MeshCellStyle -> {{1, All} -> color}, PlotTheme -> "Lines"];
Labeled[Show[{
toMesh[
Polygon@cimg[[{1, 2, 13, 14, 3, 4, 20, 19, 9, 8, 18, 17, 1}]],
Green],
toMesh[Polygon@cimg[[{5, 6, 16, 11, 22, 21, 10, 15, 7, 12, 5}]],
Blue],
toMesh[Disk[Mean /@ Transpose@cimg[[23 ;;]], 45], Red]}
], "Points to Graphics Mesh", Top, FrameMargins -> 5,
LabelStyle ->
Directive[GrayLevel[.5], FontSize -> 12,
FontFamily -> "Helvetica"]],
Labeled[
gimg = Graphics[{Green,
Polygon@cimg[[{1, 2, 13, 14, 3, 4, 20, 19, 9, 8, 18, 17, 1}]],
Blue, Polygon@cimg[[{5, 6, 16, 11, 22, 21, 10, 15, 7, 12, 5}]],
Red, Disk[Mean /@ Transpose@cimg[[23 ;;]], 45]}],
"Vector Graphics", Top, FrameMargins -> 7,
LabelStyle ->
Directive[GrayLevel[.5], FontSize -> 12,
FontFamily -> "Helvetica"]]
}} // Grid
----------
## Acknowledgment ##
At the end of this post, I'd like to thanks Wolfram Research for allowing this amazing opportunity, and special thanks to my mentors Markus van Almsick and Todd Rowland.And I guess it would be nice to finish this post with this piece of code. This time I converted the whole code into Wolfram Package :)
SetDirectory[NotebookDirectory[]];
Needs["sketchGraphics`"];
skeleton = Thinning@Binarize@EdgeDetect@Rasterize@Style["Thanks Markus !",
FontSize -> 40, FontFamily -> "Bold Italic Art"];
sketchGraphics[skeleton, BSplineCurve, 0.2];
And here is the result !
![Thanks Markus][27]
**References:**
- Mark McClure, "Polyline Simplification", http://demonstrations.wolfram.com/PolylineSimplification/
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1.PNG&userId=884569
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2.PNG&userId=884569
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3.png&userId=884569
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4.PNG&userId=884569
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6.PNG&userId=884569
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7.PNG&userId=884569
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8.PNG&userId=884569
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9.PNG&userId=884569
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10.PNG&userId=884569
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=11.PNG&userId=884569
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=12.PNG&userId=884569
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=13.png&userId=884569
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=14.svg&userId=884569
[14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=15.png&userId=884569
[15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=15.svg&userId=884569
[16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=16.png&userId=884569
[17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=16.svg&userId=884569
[18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=17.png&userId=884569
[19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=17.svg&userId=884569
[20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=18.png&userId=884569
[21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=18.svg&userId=884569
[22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=19.png&userId=884569
[23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=19.svg&userId=884569
[24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=98495.PNG&userId=884569
[25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=20.PNG&userId=884569
[26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2.PNG&userId=884569
[27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=20.svg&userId=884569Sa'di Altamimi2017-08-09T15:13:40ZTopology Optimization in Stress-Strain problem
http://community.wolfram.com/groups/-/m/t/1163322
## Introduction ##
Good day for everyone.
I want to represent one of my work in Wolfram Mathematica. The main idea was a creating of fast algorithm of topology optimization for solid objects. The most commons methods for this is a BESO (Bi-directional evolutionary structural optimization) and SIMP (Solid isotropic material with penalization). Both methods have the same idea: minimization of function like a full-strain energy in object or heat flow through the external surface of object ant etc. Optimization methods have used in aircraft/spacecraft engineering or automobile engineering. So I want to create my own algorithm in Wolfram Mathematica for topology optimization. I wll show some examples with different boundary conditions for proving that this work with different shapes and constraints.
## Some examples ##
Examples of this optimizations:
Minimization of maximum of temperature in radiator: We have metal plate. We must create the shape of this plate which provide us the minimum of maximum temperature in this plate. But we have some constraints: we have a fixed amount of material. We can wisely redistribute all material in space for creating optimal shape. At the beginning of optimization process we have homogeneus structure. Then we apply two algorithms.
**Initial** state:
![enter image description here][1]
**BESO** optimization:
![enter image description here][2]
**SIMP** Optimization:
![enter image description here][3]
As we see, those algorithms had as results the differents shapes. The main reason is a different types of redistribution of material in space. **BESO** can only move the mass in space, so we will have the void in space. It marked as *black* regions on image. In **SIMP** method we can partially fill the space by material, so we will have *gray* regions. We can consider many examples of applications both of this methods.
## Planning of the work ##
But I want to show the main Idea of this topic: I wanted to realize SIMP method in Wolfram Mathematica and build my own method for topology optimization. I divided this plan in some steps:
- FEM modelling of 2D objects: plains, shells, beam, etc
- Reproducing the SIMP algorithm in Mathematica over 2D regions
- Checking the results
- FEM modelling of 3D object
- Reproducing the SIMP algorithm over 3D regions
- Checking the results
- Thinking about own idea of topology optimization for minimization of strain energy
- Realization of this idea
- Compairing new method with SIMP
- Optimization of new algorithm
## First steps ##
SIMP method based on FEM. It suppose to create virtual field of density. So we have a new parameter for each Finite Element: density. Then we try to find the value of each density which provide us a minimum of goal function. In Wolfram Mathematica we have big diversity of methods for discretization of regions and further analysis. We have a rectangle and discretize it by triangles:
Reg = DiscretizeRegion[Parallelogram[{0, 0}, {{0, a1}, {a2, 0}}], MeshCellLabel -> {0 -> "Index"},
MaxCellMeasure -> .01];
Coord = MeshCoordinates[Reg];
Polys = MeshCells[Reg, 2];
ActionSquare = Show[Reg, ImageSize -> 600]
![enter image description here][4]
Polys contains all information about each Finite Element (Triangles), Coord contains all coordinates of all points. By this data we can construct the Stiffness Matrix of this object for solving the Stress-Strain problem. As the result of solving this problem we get the vectors of displacements, strains and stresses in each finite element. We can visualize it, as examples: von Mises stresses in axis-Symmetrical problem, red - biggest stresses, blue and violet - lowest stresses:
![enter image description here][5]
## 2D Solutions of SIMP method ##
Then we can use SIMP method algorithm on this solution for redistributing the material in space, we move the material from non-stressed areas into area with big amount of stresses. SIMP - iterative method, so we will get a result after some steps. SIMP also have a big amount of control parameters: penalizing factor, continuum coefficient and etc.
- Big size of cells:
![enter image description here][6]
- Small cells:
![enter image description here][7]
We can analyse the main criteria of optimization: ***full energy of strain***
![enter image description here][8]
**X-axis** is an iteration of SIMP method, so we get final solution at 12~13 step. Different dashing - different parameters of optimization, we see that it change only the "way" of optimization. We can see that energy decreases from step to step, so the main goal was completed. So I realized the SIMP method in WM. You can look at this on my [GitHub][9].
## Main Part ##
We must do the same things in 3D. I will skip all explanations in this part because they are the same as in 2D. I will show some examples of optimization:
- Initial conditions
![enter image description here][10]
- Result of SIMP Optimization
![enter image description here][11]
But I must say that in case of 3D problem the level of computations grows very fast. So on my notebook it is very hard to analyse the big amount of Finite Elements for Topology optimization. I began to seek the to minimize my computations. We have only a hypothesis about existing only one global extremum point of our function. If we consider that it is ***true*** we have a very fast solution. We must construct a goal function of many arguments.
goalFunction = displacement.StifnessMatrix.displacement;
massEquation =
Sum[V[[k]]*density[[k]], {k, 1, Length[Tetras]}] ==
Sum[V[[k]], {k, 1, Length[Tetras]}]*0.75;
densityEq = Thread[0.0 <= # <= 1 &[density]];
The goal function is a strain energy in solid object. Arguments - densities of Finite Elements. And also we have some constraints, we can't involve new mass in space, our elements can't be overcrowded. ***displacement*** it is a vector of displacements of each points of our discretized object. We get it from solving Stress-Strain problem. StiffnessMatrix we get from the properties of our object. ***density*** is vector of density of each finite element.
sysOfEq = Flatten[{goalFunction, massEquation, Equation, densityEq}];
variables = Flatten[{density, DisplacementI}];
Here we construct the system of equation for our problem and vector of our variables. I suppose to use **FindMinimum** function for finding the global minimum of our function. But we must define the initial point for seeking the minimum point.
initDis = Thread[{#, 0} &[DisplacementI]];
initDen = Thread[{#, 0.5} &[density]];
initCond = Flatten[{initDen, initDis}, 1];
Then we try to run the FindMinimum with this initial conditions and equations:
resultFMin =
Quiet[FindMinimum[sysOfEq, initCond,
Method -> "InteriorPoint"]]; // AbsoluteTiming
And after this, I got the incredible results. The vectors of density for **SIMP** method and **FindMinimum** сoincide almost completely. I got the increasing of computation speed near x40 in compairing with SIMP algorithm. You can look at all result also on my [GitHub][12].
## Conclusions ##
- FindMinimum give the same result as the SIMP method for stress-strain problem;
- It has a very big advantage in time in compairing with SIMP, SIMP/FindMinimumTime~40-50;
- I must prove the hypothesis about the one global minimum of the multidimensional function. If anyone can give me some advices about this.
- We can use this for constructing optimized models for 3D printing. It was introduced in WM v11.0.0
![enter image description here][13]
## Further explorations ##
- In Mathematica we can find some FEM packages: NDSolve`FEM` or ACEFEM package from Korelc Jože. I want to try connect them in something.
- Create the CDF application for simpliest application of Topology Optimization.
- Further analysis of finding the global minimum of goal function.
- Improving the algorithm of constructing StiffnessMatrix and finding minimum. I mean construct own specialized function for this problem.
## Questions ##
- How I can prove the existing only one minimum of multidimensional function with Mathematica.
## Link for video ##
[Video][14]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=11.PNG&userId=1083954
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=22.PNG&userId=1083954
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=33.PNG&userId=1083954
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=44.PNG&userId=1083954
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=55.PNG&userId=1083954
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=66.PNG&userId=1083954
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=77.PNG&userId=1083954
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=88.PNG&userId=1083954
[9]: https://github.com/AndreyKrotkikh/TopologyOptimization
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=99.PNG&userId=1083954
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=111.PNG&userId=1083954
[12]: https://github.com/AndreyKrotkikh/TopologyOptimization
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=122.jpg&userId=1083954
[14]: https://drive.google.com/open?id=0BwoYVUBhV8KJbGdwNmpKZWk4MWcAndrey Krotkikh2017-08-11T19:08:54Z[WSS17] Non-SyntaxQ correction to SyntaxQ
http://community.wolfram.com/groups/-/m/t/1136114
## Main Idea ##
The main Idea of this project is: Find ways for correcting non-SyntaxQ expressions to SyntaxQ expressions.
As example: we have this string: `"Fold[Plus,a,{b,c,d,e}]". We can remove it one character from this string and get a `StringLength["Fold[Plus,a,{b,c,d,e}]"]` different strings. We can get it by
inp = "Fold[Plus,a,{b,c,d,e}]";
StringDrop[inp, {#}] & /@ Range[StringLength[inp]]
So, it will 22 different strings:
`old[Plus,a,{b,c,d,e}]
Fld[Plus,a,{b,c,d,e}]
...
Fold[Plus,a,{b,c,d,e]
Fold[Plus,a,{b,c,d,e}`
Some of them will give us `True` for function `SyntaxQ`. Let's try sort it by `Select`:
dropped = StringDrop[inp, {#}] & /@ Range[StringLength[inp]]
Select[dropped, Not[SyntaxQ[#]] &]
And we got only 4 results from 22:
`FoldPlus,a,{b,c,d,e}]
Fold[Plus,a,b,c,d,e}]
Fold[Plus,a,{b,c,d,e]
Fold[Plus,a,{b,c,d,e}
`
Let's try to evaluate it by function `ToExpression`.
Map[ToExpression, Select[dropped, Not[SyntaxQ[#]] &]]
And we get list of errors:
`{$Failed, $Failed, $Failed, $Failed}`
It means that code are not correct, but it will be necessary to check `ToExpression` on not filtered list of strings:
Map[ToExpression, dropped]
`{old[Plus,a,{b,c,d,e}]
Fld[Plus,a,{b,c,d,e}]
Fod[Plus,a,{b,c,d,e}]
Fol[Plus,a,{b,c,d,e}]
$Failed
lus[lus[lus[lus[a,b],c],d],e]
Pus[Pus[Pus[Pus[a,b],c],d],e]
Pls[Pls[Pls[Pls[a,b],c],d],e]
Plu[Plu[Plu[Plu[a,b],c],d],e]
Plusa[Plusa[Plusa[b,c],d],e]
b+c+d+e+Null
a b+a c+a d+a e
$Failed
a+c+d+e+Null
a+bc+d+e
a+b+d+e+Null
a+b+cd+e
a+b+c+e+Null
a+b+c+de
a+b+c+d+Null
$Failed
$Failed`
As we see, some of them were evaluated without any errors. It is normal because of `old, Fld, Fod, Fol, etc.,` counts as non defined functions. `Null` also counts as argument of function. It is the main reason of filtering the *dropped* list of strings. Next step of this topic is the finding way of correction our strings. So, we must construct the algorithm which will correct all `$Failed` strings into SyntaxQ forms.
![Graph of correction][1]
## "Intellectual" inserting ##
The general way to correction is defining of missing character and adding it in every place of our string. Then we must check all our new inputs for Syntax corectness.
Inserting of missed character, general way:
correctInserting[str_String, strinst_String] :=
Module[{s = str, s1, s2, result = {}, i, symb = strinst},
s1 = StringSplit[str, x : PunctuationCharacter :> x];
For[
i = 1, i <= Length[s1], i++,
If[
Not[MemberQ[$SystemSymbols, s1[[i]]]],
s2 =
{# + Total[StringLength[#] & /@ (s1[[1 ;; i - 1]])],
StringInsert[s1[[i]], symb, {#}]} &
/@ Range[StringLength[s1[[i]]] + 1];
AppendTo[
result, {s2[[#, 1]], {s1[[1 ;; i - 1]], s2[[#, 2]],
s1[[i + 1 ;;]]}} & /@ Range[StringLength[s1[[i]]] + 1]]
]
];
DeleteDuplicates[Transpose[{Transpose[Flatten[result, 1]][[1]],
StringJoin /@ Transpose[Flatten[result, 1]][[2]]}]]
So, this function won't insert character into functions which are in:
Names["System`*"]
## First approach ##
I tried 2 approaches: using of string patterns and using internal service of Mathematica for checking the errors. During my work in WSS2017 I chosed the second way. But let's explain why? The main idea of pattern system was a decomposition of our string into substrings. As example:
`Fold[f,x,{1,2,3}] -> {Fold,f,x,{1,2,3}}`
Then we check each element by SyntaxQ;
SyntaxQ/@{Fold,f,x,{1,2,3}}
Then we convert a list of boolean values into list of 1 and 0 by `Boole`.
Boole[SyntaxQ/@{Fold,f,x,{1,2,3}}]
I supposed that a decomposition which have a biggest number in binary representation is right correction of our string. But this way can't maintain all possible variant. Introducing the function equal to `Boole` but in terms of ternary system or quarternary. I tried to reproduce the ternary equivalent of `Boole` and it can maintain more kinds of inputs.
But this system have many disadvantages: slow, inefficient, etc.
I will show the last version of string patterns system of this:
brPrSol3[str_String] :=
Module[{x = str, result},
fbr =
FixedPointList[
StringReplace[
#,
x__ ~~ "[" ~~ y__ ~~ "]" ~~ z___ /;
StringCount[y, "["] == StringCount[y, "]"] &&
StringCount[x, {"[", "]"}] == 0 &&
ContainsAny[Names["System`*"], {x}] &&
StringCount[z, {"[", "]"}] == 0 &&
commaCounter[x] ==
StringCount[emptyBracketCollapse@bracesCollapse@y, ","]
:> y
] &,
str
];
result = Flatten[fbr]
]
It worked very slow and always I could give input which would not give me correct output:
Subsets[{a, b, c]
You can look at this pattern system on my [GitHub][2] or by this [directlink][3].
## Second approach ##
The second way is using `Block` construction:
messageAnalysis[str_] :=
Module[{mess, result},
Block[{$MessageList = {}},
Quiet[
ToExpression[str];
mess = $MessageList;
];
result = (mess === {})
];
result
];
So, If we have any message it will give us `False`. And this function `messageAnalyser` allow to analyse all our construction more precisely.
You can look at this more [here][4]. `messageAnalysis` allow us to check each results of `correctInserting`. Then we introduce some filters:
testAnalyser[str_String, initStr_, nulltest_] :=
messageAnalysis[str] &&
EditDistance[
StringDelete[ToString[ToExpression[str], InputForm],
WhitespaceCharacter], initStr] >=
1 && (StringCount[
StringDelete[ToString[ToExpression[str], InputForm],
WhitespaceCharacter], "Null"] == 0 || Not[nulltest])
By `nulltest` we can sort result into two piles: `Not contains Null` and `Can contains Null`. Also we remove all results which have `EditDistance` with initial string less than 1. Full code you can look [here][5].
## Panel Version ##
Also we tried to do something like an application for live-correcting input cell:
Panel[
Style[
Column[
{
InputField[Dynamic[inpstr], String, ContinuousAction -> True],
Dynamic[Quiet[syntaxCorrector[inpstr]]]
}
], Background -> White
]
]
![1st example][6]
![2nd example][7]
![enter image description here][8]
![enter image description here][9]
## "Prototype" of Neural Net ##
We built a prototype of neural net, that maybe be able to learn a templates of Wolfram Language. I don't have enought time for immerse myself in the topic of neural networks for finishing this part of WSS project.
validCharacters = StringJoin@CharacterRange[30, 125];
net00 = NetGraph[
<|
"revIn" -> SequenceReverseLayer[],
"encGRU<" -> GatedRecurrentLayer[96],
"revOut" -> SequenceReverseLayer[],
"encGRU>" -> GatedRecurrentLayer[96],
"cat" -> CatenateLayer[2],
"decGRU" -> GatedRecurrentLayer[96],
"classifier" -> NetMapOperator[
NetChain[{LinearLayer[StringLength[validCharacters]],
SoftmaxLayer[]}]
]
|>,
{NetPort["Input"] -> "revIn" -> "encGRU<" -> "revOut",
NetPort["Input"] -> "encGRU>", {"revOut", "encGRU>"} ->
"cat" -> "decGRU" -> "classifier" },
"Input" -> NetEncoder[{"Characters", validCharacters, "UnitVector"}],
"Output" -> NetDecoder[{"Characters", validCharacters}]
]
![Neural Net][10]
## Conslusions ##
- We have a algorithm that can work with all types of string where we can correct it only by adding 1 character.
- We have a prototype of neural net and dataset for it.
## Future directions ##
- Complete the neural net.
- Introduce the new features in algorithm.
- Improve algorithm by adding a possibility to add in string 2 or more additional characters.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ssss.PNG&userId=1083954
[2]: https://github.com/AndreyKrotkikh
[3]: https://github.com/AndreyKrotkikh/WSS2017/blob/master/SyntaxCorrector.nb
[4]: https://github.com/AndreyKrotkikh/WSS2017/blob/master/FinalVersion.nb
[5]: https://github.com/AndreyKrotkikh/WSS2017/blob/master/FinalVersion.nb
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=s1.PNG&userId=1083954
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=s2.PNG&userId=1083954
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=s3.PNG&userId=1083954
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=s4.PNG&userId=1083954
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=s5.PNG&userId=1083954Andrey Krotkikh2017-07-05T19:25:02ZFind all pairs of common tangents to a curve?
http://community.wolfram.com/groups/-/m/t/1166192
My question is kind of an extension of a question asked previously (https://mathematica.stackexchange.com/questions/25892/common-tangent-to-a-curve) . The difference is that(instead of just one pair) I need to find all pairs of common tangents to a plot.
The list is
normalizedfplot={{0.01, 0.}, {0.02, -0.0000539749}, {0.03, -0.000101768}, {0.04, \
-0.000147006}, {0.05, -0.000191386}, {0.06, -0.000235889}, {0.07, \
-0.000281142}, {0.08, -0.000327577}, {0.09, -0.000375499}, {0.1, \
-0.000425131}, {0.11, -0.000476637}, {0.12, -0.000530134}, {0.13, \
-0.000585708}, {0.14, -0.000643418}, {0.15, -0.000703296}, {0.16, \
-0.00076536}, {0.17, -0.000829608}, {0.18, -0.000896023}, {0.19, \
-0.000964576}, {0.2, -0.00103522}, {0.21, -0.0011079}, {0.22, \
-0.00118255}, {0.23, -0.00125909}, {0.24, -0.00133741}, {0.25, \
-0.00141742}, {0.26, -0.00149898}, {0.27, -0.00158197}, {0.28, \
-0.00166622}, {0.29, -0.00175156}, {0.3, -0.0018378}, {0.31, \
-0.00192473}, {0.32, -0.00201211}, {0.33, -0.00209968}, {0.34, \
-0.00218713}, {0.35, -0.00227415}, {0.36, -0.00236037}, {0.37, \
-0.00244538}, {0.38, -0.00252871}, {0.39, -0.00260987}, {0.4, \
-0.00268827}, {0.41, -0.00276326}, {0.42, -0.00283413}, {0.43, \
-0.00290008}, {0.44, -0.00296023}, {0.45, -0.00301362}, {0.46, \
-0.00305925}, {0.47, -0.00309612}, {0.48, -0.00312327}, {0.49, \
-0.00313991}, {0.5, -0.00314552}, {0.51, -0.00313991}, {0.52, \
-0.00312327}, {0.53, -0.00309612}, {0.54, -0.00305925}, {0.55, \
-0.00301362}, {0.56, -0.00296023}, {0.57, -0.00290008}, {0.58, \
-0.00283413}, {0.59, -0.00276326}, {0.6, -0.00268827}, {0.61, \
-0.00260987}, {0.62, -0.00252871}, {0.63, -0.00244538}, {0.64, \
-0.00236037}, {0.65, -0.00227415}, {0.66, -0.00218713}, {0.67, \
-0.00209968}, {0.68, -0.00201211}, {0.69, -0.00192473}, {0.7, \
-0.0018378}, {0.71, -0.00175156}, {0.72, -0.00166622}, {0.73, \
-0.00158197}, {0.74, -0.00149898}, {0.75, -0.00141742}, {0.76, \
-0.00133741}, {0.77, -0.00125909}, {0.78, -0.00118255}, {0.79, \
-0.0011079}, {0.8, -0.00103522}, {0.81, -0.000964576}, {0.82, \
-0.000896023}, {0.83, -0.000829608}, {0.84, -0.00076536}, {0.85, \
-0.000703296}, {0.86, -0.000643418}, {0.87, -0.000585708}, {0.88, \
-0.000530134}, {0.89, -0.000476637}, {0.9, -0.000425131}, {0.91, \
-0.000375499}, {0.92, -0.000327577}, {0.93, -0.000281142}, {0.94, \
-0.000235889}, {0.95, -0.000191386}, {0.96, -0.000147006}, {0.97, \
-0.000101768}, {0.98, -0.0000539749}, {0.99, 0.}}
The plot looks like this
![enter image description here][1]
Now when I use the code used in the solution to the previous problem, it gives me only one solution.
fo = Interpolation[normalizedfplot, Method -> "Spline"];
boundary = FindRoot[{y1==fo[x1],y2==fo[x2], fo'[x1]==fo'[x2], fo'[x1]==(y2-y1)/(x2-x1)},
{x1,0.01},{x2,0.5},{y1,-0.025},{y2,-0.0275}]
{x1 -> 0.00124073, x2 -> 0.419065, y1 -> 0.000055584,
y2 -> -0.0028277}
This gives me only one pair of solution (if lucky). I need a code that will work for any plot and give me all pairs of common tangents (like there are two pairs in the above plot-one pair given above and the other pair approximately 0.6-0.99). Using NSolve did not help either.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4042improvedsol3.png&userId=1146915Deb Chicago2017-08-16T23:49:26Z[✓] Solve and plot an integration with 2 variables?
http://community.wolfram.com/groups/-/m/t/1166540
Dear All,
I've tried to plot a function containing an integration with two variables, and encountered converging problem.
The code has running for more than 24 hours but still running....
Could you kindly help me what could be the problem? Is there any better way to write the code that it converge much quicker?
Thank you very much in advance!
Yujin
The code is attached!Yujin Tong2017-08-17T12:28:39Z[✓] ContourPlot 2 variables functions in W|A?
http://community.wolfram.com/groups/-/m/t/1166234
Hello i was testing out wolfram|Alpha for the first times with 2 variables functions and it seems that it's pretty inacurate.
As u can see in the image below, where i zoomed the contour plot, a point that is in clearly in the orange part has a lower value than a point clearly in the red part. it should be the contrary since the whiter the higher right ?
[link to the wolfram page to see it in live][1]
![enter image description here][2]
[1]: https://www.wolframalpha.com/input/?i=Plot3D%5B%28472,5%2bx%29*%28101,8%2by%29,%20%7Bx,%200,%20500%7D,%20%7By,%200,%2020%7D%5D
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=wolframe.png&userId=1166218ALEXANDRE SCHYNS2017-08-17T04:10:50Z