Putting a smooth curve inside of a tube - wolfram-mathematica

What is a good way to draw a smooth curve with specified starting and ending point and restricted to be inside of a piecewise linear tube like below?
(source: yaroslavvb.com)
coords = {1 -> {0, 2}, 2 -> {1/3, 1}, 3 -> {0, 0},
4 -> {(1/3 + 2)/2, 1}, 5 -> {2, 1}, 6 -> {2 + 1/3, 0},
7 -> {2 + 1/3, 2}};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 6, 5 -> 7};
path = {3, 2, 4, 5, 7};
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[lp, gp, PlotRange -> pr, ImageSize -> is]

Perhaps something like this:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
f = BezierFunction[
SortBy[coords /. Rule[x_, List[a_, b_]] -> List[a, b], First]];
pp = ParametricPlot[f[t], {t, 0, 1}];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, lp, gp, PlotRange -> pr, ImageSize -> is]
You may gain a better control over the path by adding/removing control points for the Bezier. As I remember "A Bspline is contained in the convex hull of its control points", so you can add control points inside your thick lines (up and down the middlepoints in actual point set, for example) to bound the Bezier more and more.
Edit
The following is a first try to bound the curve. Bad programming, just to get the feeling of what can be done:
coords = {2 -> {1/3, 1}, 1 -> {0, 0}, 3 -> {(1/3 + 2)/2, 1},
4 -> {2, 1}, 5 -> {2 + 1/3, 2}};
pr = {{-1, 3 + 1/3}, {-1 - 1/6, 3 + 1/6}};
scale = 50;
is = -scale*(Subtract ### pr);
lineThickness = 2/3;
graph = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 5};
gp = GraphPlot[graph, VertexCoordinateRules -> coords];
path = {1, 2, 3, 4, 5};
kk = SortBy[coords /. Rule[x_, List[y_, z_]] -> List[y, z],
First]; f = BezierFunction[kk];
pp = ParametricPlot[f[t], {t, 0, 1}, Axes -> False];
mp = Table[{a = (kk[[i + 1, 1]] - kk[[i, 1]])/2 + kk[[i, 1]],
Interpolation[{kk[[i]], kk[[i + 1]]}, InterpolationOrder -> 1][
a] + lineThickness/2}, {i, 1, Length[kk] - 1}];
mp2 = mp /. {x_, y_} -> {x, y - lineThickness};
kk1 = SortBy[Union[kk, mp, mp2], First]
g = BezierFunction[kk1];
pp2 = ParametricPlot[g[t], {t, 0, 1}, Axes -> False];
lp = Graphics[{Blue, Opacity[.5],
AbsoluteThickness[lineThickness*scale], Line[path /. coords]}];
Show[pp, pp2, lp, gp, PlotRange -> pr, ImageSize -> is]
Edit 2
Or perhaps better yet:
g1 = Graphics[BSplineCurve[kk1]];
Show[lp, g1, PlotRange -> pr, ImageSize -> is]
This one scales quite well when you enlarge the image (the previous ones don't)

Related

Finding intersection of two function using Mathematica

I used the following to graph my two functions:
p1 = Plot[100 t^2*Sin[Sqrt[t]], {t, 0, 7}, AxesOrigin -> {0, 5000}]
p2 = Plot[Piecewise[{{250, 0 <= t < 3}, {2000, 3 < t <= 7}}], {t, 0, 7},
AxesOrigin -> {0, 5000}]
I can not figure out how to find the intersection of the graph, please help.
Using FindRoot with initial guesses observed from the plots.
sol = FindRoot[100 t^2*Sin[Sqrt[t]] == 250, {t, 2}];
t1 = t /. sol
1.61743
sol = FindRoot[100 t^2*Sin[Sqrt[t]] == 2000, {t, 5}];
t2 = t /. sol
5.07622
y = With[{t = 3}, 100 t^2*Sin[Sqrt[t]]];
p1 = Plot[100 t^2*Sin[Sqrt[t]], {t, 0, 7}, AxesOrigin -> {0, 5000}];
p2 = Plot[Piecewise[{{250, 0 <= t < 3}, {2000, 3 < t <= 7}}], {t, 0, 7},
AxesOrigin -> {0, 5000}, Exclusions -> None];
Show[p1, p2, ListPlot[{{t1, 250}, {t2, 2000}, {3, y}},
PlotStyle -> PointSize[0.03]]]

highlight fit region in mathematica errorbar plot

I would like to highlight the fit region in a mathematica graph with appropriate fit error bar on it. To plot some data with error bar I write for example:
data={{{0, 0.00126517235028},
ErrorBar[0.0097546177348]}, {{1, 0.0132870239578},
ErrorBar[0.00717311242327]}, {{2, 0.00968907928987},
ErrorBar[0.0125454440978]}, {{3, 0.00835906062474},
ErrorBar[0.0196027916911]}, {{4, 0.0141038637039},
ErrorBar[0.0288324766544]}, {{5, 0.0467626302256},
ErrorBar[0.0423090450838]}, {{6, 0.0832535249208},
ErrorBar[0.0609066442506]}};
ErrorListPlot[p0all67, Frame -> True,
PlotRange -> {{0, 6}, {0.3, -0.04}}, Axes -> False,
PlotStyle -> {AbsolutePointSize[10], AbsoluteThickness[2]}]
Now I fit the data in anther software using linear fit method and for example, the fit result(or slope) in x=4 to x=6 is 0.0317349, and error bar is 0.0215005. I would like to highlight the fit region with this fit value and the error. So i expect the graph to look something like this:
Could anybody please help me how to do this? Thanks.
Needs["ErrorBarPlots`"];
data = {{{0, 0.00126517235028},
ErrorBar[0.0097546177348]}, {{1, 0.0132870239578},
ErrorBar[0.00717311242327]}, {{2, 0.00968907928987},
ErrorBar[0.0125454440978]}, {{3, 0.00835906062474},
ErrorBar[0.0196027916911]}, {{4, 0.0141038637039},
ErrorBar[0.0288324766544]}, {{5, 0.0467626302256},
ErrorBar[0.0423090450838]}, {{6, 0.0832535249208},
ErrorBar[0.0609066442506]}};
elp = ErrorListPlot[data, Frame -> True,
PlotRange -> {{0, 6}, {-0.05, 0.18}}, Axes -> False,
PlotStyle -> {AbsolutePointSize[7], AbsoluteThickness[1]},
PlotRangePadding -> {0.4, 0}];
m = 0.0317349;
line[x_, c_] := m x + c;
{x4, y4} = data[[5, 1]];
ytest = line[x4, 0];
c = y4 - ytest;
check = line[x4, c];
x6 = 6;
y6 = line[x6, c];
delta = 0.0215005;
a = {{x4, y4 + delta}, {x6, y6 + delta}};
b = {{x4, y4 - delta}, {x6, y6 - delta}};
Show[elp,
ListLinePlot[{{x4, y4}, {x6, y6}}, PlotStyle -> Thick],
ListLinePlot[{a, b}, Filling -> {1 -> {2}}, PlotStyle -> None],
ImageSize -> 500]
Here is also an example based on your data demonstrating some statistics functions.
data = {0.00126517235028, 0.0132870239578, 0.00968907928987,
0.00835906062474, 0.0141038637039, 0.0467626302256, 0.0832535249208};
lm = LinearModelFit[data, {1, x , x^2, x^3}, x];
{sd1, sd2} = 2*(CDF[NormalDistribution[0, 1], #] - 0.5) & /# {1, 2};
intervals = Flatten[Transpose /# Table[
lm["SinglePredictionConfidenceIntervals", ConfidenceLevel -> cl],
{cl, {sd1, sd2}}], 1];
{bands68[x_], bands95[x_]} = Table[
lm["SinglePredictionBands", ConfidenceLevel -> cl], {cl, {sd1, sd2}}];
Show[ListPlot[data, PlotMarkers -> Automatic], ListPlot[intervals],
Plot[{lm[x], bands68[x], bands95[x]}, {x, 5, 8}, Filling -> {2 -> {1}, 3 -> {2}}],
PlotRange -> {{1, 7}, {-0.02, 0.1}}, ImageSize -> 480, Frame -> True, Axes -> False]

How to get array of deleted walls from maze generation code Mathematica

I am trying to get out an array of all the deleted walls from this maze generation code. Can't seem to make it work, when I ask it to print it will only give me the entire maze grid, and not the specific walls I'm asking for.
MazeGen2[m_, n_] :=
Block[{$RecursionLimit = Infinity,
unvisited = Tuples[Range /# {m, n}], maze, mazearray = {},
mazeA},
(*unvisited=Delete[unvisited,{{1},{2},{Length[
unvisited]-1},{Length[unvisited]}}];*)
(*Print[unvisited];*)
maze = {{{{#, # - {0, 1}}, {#, # - {1, 0}}}} & /#
unvisited, {{{0, n - 1}, {0, 0}, {m - 1,
0}}}};(*This generates the grid*)
Print[maze];
{unvisited = DeleteCases[unvisited, #];
(*Print[unvisited];*)
Do[
If[MemberQ[unvisited, neighbor],
maze = DeleteCases[
maze, {#, neighbor - {1, 1}} | {neighbor, # - {1, 1}}, {5}]
(*mazeA=Flatten[AppendTo[mazearray,
maze]];*)
; #0#neighbor],
{neighbor,
RandomSample#{# + {0, 1}, # - {0, 1}, # + {1, 0}, # - {1,
0}}}
]
} &#RandomChoice#unvisited;
Flatten[maze]
];
I tracked down your code to the Rosetta Code site, and - by way of thanks for that! - here's how to use the graph-based alternative for maze generation. This is courtesy of user AlephAlpha:
MazeGraph[m_, n_] :=
Block[{$RecursionLimit = Infinity, grid = GridGraph[{m, n}],
visited = {}},
Graph[Range[m n],
Reap[{AppendTo[visited, #];
Do[
If[FreeQ[visited, neighbor],
Sow[# <-> neighbor]; #0#neighbor],
{neighbor, RandomSample#AdjacencyList[grid, #]}]} & #
RandomChoice#VertexList#grid][[2, 1]],
GraphLayout -> {"GridEmbedding", "Dimension" -> {m, n}},
EdgeStyle -> Directive[Opacity[1], AbsoluteThickness[12], Purple],
VertexShapeFunction -> None,
VertexLabels -> "Name",
VertexLabelStyle -> White,
Background -> LightGray,
ImageSize -> 300]];
width = height = 8;
maze = MazeGraph[width, height]
Solutions are easy now that the maze is a graph:
path = FindShortestPath[maze, 1, Last[VertexList[maze]]];
solution = Show[
maze,
HighlightGraph[
maze,
PathGraph[path],
EdgeStyle -> Directive[AbsoluteThickness[5], White],
GraphHighlightStyle -> None]
];
and also easy is to find the deleted walls - here, it's the GraphDifference between the original GridGraph and the maze:
hg = HighlightGraph[
GridGraph[{width, height},
EdgeStyle ->
Directive[Opacity[0.2], Blue, AbsoluteThickness[1]]],
EdgeList[GraphDifference[GridGraph[{width, height}], maze]],
Background -> LightGray,
ImageSize -> 300,
GraphHighlightStyle -> {"Thick"}];
Showing all three:
Row[{Labeled[maze, "maze"], Spacer[12], Labeled[hg, "deleted walls"],
Labeled[solution, "solution"]}]
Apologies for the styling issues - this is the hard part of using graphs... :)

Graphical Representation of Lists

Say I have three lists: a={1,5,10,15} b={2,4,6,8} and c={1,1,0,1,0}. I want a plot which has a as the x axis, b as the y axis and a red/black dot to mark 1/0. For. e.g. The coordinate (5,4) will have a red dot.
In other words the coordinate (a[i],b[i]) will have a red/black dot depending on whether c[i] is 1 or 0.
I have been trying my hand with ListPlot but can't figure out the options.
I suggest this.
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
Graphics[
{#, Point#{##2}} & ###
Thread#{c /. {1 -> Red, 0 -> Black}, a, b},
Axes -> True, AxesOrigin -> 0
]
Or shorter but more obfuscated
Graphics[
{Hue[1, 1, #], Point#{##2}} & ### Thread#{c, a, b},
Axes -> True, AxesOrigin -> 0
]
Leonid's idea, perhaps more naive.
f[a_, b_, c_] :=
ListPlot[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}]
f[a, b, c]
Edit: Just for fun
f[h_, a_, b_, c_, opt___] :=
h[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}, opt]
f[ ListPlot,
Sort#RandomReal[1, 100],
Sin[(2 \[Pi] #)/100] + RandomReal[#/100] & /# Range[100],
RandomInteger[1, 100],
Joined -> True,
InterpolationOrder -> 2,
Filling -> Axis]
Here are your points:
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
(I deleted the last element from c to make it the same length as a and b). What I'd suggest is to separately make images for points with zeros and ones and then combine them - this seems easiest in this situation:
showPoints[a_, b_, c_] :=
With[{coords = Transpose[{a, b}]},
With[{plotF = ListPlot[Pick[coords, c, #], PlotMarkers -> Automatic, PlotStyle -> #2] &},
Show[MapThread[plotF, {{0, 1}, {Black, Red}}]]]]
Here is the usage:
showPoints[a, b, c]
One possibility:
ListPlot[List /# Transpose[{a, b}],
PlotMarkers -> {1, 1, 0, 1} /. {1 -> { Style[\[FilledCircle], Red], 10},
0 -> { { Style[\[FilledCircle], Black], 10}}},
AxesOrigin -> {0, 0}]
Giving as output:
You could obtain similar results (to those of Leonid) using Graphics:
Graphics[{PointSize[.02], Transpose[{(c/. {1 -> Red, 0 -> Black}),
Point /# Transpose[{a, b}]}]},
Axes -> True, AxesOrigin -> {0, 0}]

Mathematica: Getting rid of the "x ->" in FindInstance results

Suppose I have the following results:
a=FindInstance[2*b^2 + b^3 == b^4 + t && t < 10 && t > -1, {b, t},
Integers, 20]
{{b -> -1, t -> 0}, {b -> 0, t -> 0}, {b -> 1, t -> 2}, {b -> 2,
t -> 0}}
How can I get rid of the "b->" and just get the array of b answers? I can get halfway there with:
a[[All,1]]
{b -> -1, b -> 0, b -> 1, b -> 2}
but how can I get to just:
{-1, 0, 1, 2}
Thanks
I might be missing something from dreeves' answer, but the way I always believed you do this was simply by writing:
b /. a
There is an example of this in the "Basic Examples" section of the documentation for the Solve function, which uses the same output style.
Though Will's answer is the canonical way to do it, I'll provide a few alternatives just for fun.
In[37]:= ans={{b -> -1, t -> 0},{b -> 0, t -> 0},{b -> 1, t -> 2},{b -> 2, t -> 0}};
In[38]:= Cases[ans, (b -> a_) :> a, Infinity]
Out[38]= {-1, 0, 1, 2}
In[39]:= ans[[All, 1]][[All, 2]]
Out[39]= {-1, 0, 1, 2}
In[40]:= ans /. {b -> a_, _} :> a
Out[40]= {-1, 0, 1, 2}
In[41]:= (ans /. Rule -> List)[[All, 1, 2]]
Out[41]= {-1, 0, 1, 2}

Resources