MMA如何绘制出如图所示效果 [已关闭]

Question

ContourPlot[
 E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}, 
 MaxRecursion -> 0, PlotPoints -> 1500]

事实上，别的绘图软件很容易绘出如下效果

用下面的代码的话，为什么左下方多出一部分矩形，并且右上方矩形成型效果很差

Clear["`*"];
data = Compile[{}, 
    With[{y = Range[-10, 10, .01]}, 
     Abs@Table[Clip[E^(Sin[x] + Cos[y]) - Sin[E^(x + y)]], {x, y}]]][];
ArrayPlot[data, ColorFunction -> (Hue[.2, .7, 1 - #] &), 
 DataReversed -> {True, False}]

 

Comments

-1。我四个链接放出来不是让你抄的。

---

data = Table[
   With[{a = Interval[{x, x + .025}], b = Interval[{y, y + .025}]},
    IntervalMemberQ[E^(Sin[a] + Cos[b]) - Sin[E^(a + b)],
     0]], {x, -10, 10, .025}, {y, -10, 10, .025}];
ArrayPlot[Boole@Reverse[data, 1]]
这段代码效果十分满意，可是问题中那段代码多出的矩形部分和右上方矩形成形效果差的问题实在不知道该怎么调整，我只会调整左右顺序。

Answer 1

这类图在Mathematica里的简单高效的画法几乎可以说是有定论的。明明是公开的讨论却总是无法传承也是搞得我心塞：

http://tieba.baidu.com/p/2776245919?pid=43465289339&cid=0#43465289339

http://tieba.baidu.com/p/2504432886?pid=36525064381&cid=36526175919#36526175919

http://tieba.baidu.com/p/3517568789

http://tieba.baidu.com/p/2578898520

 

----

算了，贴个通用解法，想抄就抄吧：

Clear[equationPlot, gradEquationPlot, approxEquationPlot]
equationPlot[type___][expr : Except[{__}], rest__] := equationPlot[type][{expr}, rest];
equationPlot[type___][eqn : {HoldPattern@Equal[_, _] ..}, rest__] := 
  equationPlot[type][Subtract @@@ eqn, rest];

findZero["grad"] := Abs@Differences[# // UnitStep, {0, 1}] &;
findZero["approx", limit_: 1/100] := 
  Function[(1 - UnitStep[-limit - #]) (1 - UnitStep[-limit + #])];

equationPlot[type : "grad" | "approx" : "approx", limit___][
   expr_, {x_, xl_, xr_}, {y_, yl_, yr_}, step_: 1/100, prec_: MachinePrecision] := 
  With[{rx = Range[xl, xr, N[step, prec]], ry = Range[yl, yr, N[step, prec]], 
    rcolor = Range@Length@expr}, 
   ContourPlot[False, {x, xl, xr}, {y, yl, yr}]~Show~
    ArrayPlot[rcolor findZero[type, limit][
        Function[{x, y}, expr][#, ry] & /@ rx // Transpose] // Total, 
     DataReversed -> True, DataRange -> {{xl, xr}, {yl, yr}}, 
     ColorRules -> (# -> ColorData[1][#] & /@ rcolor)]];

gradEquationPlot = equationPlot["grad"];
approxEquationPlot = equationPlot["approx"];

 

equationPlot["approx", 1/10][


 E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}, 1/100]

gradEquationPlot[E^(Sin[x] + Cos[y]) == Sin[E^(x + y)], {x, -10, 10}, {y, -10, 10}]

Comments

没想到可以用ArrayPlot，这样就简单了。又长知识了。

---

Clear["`*"];
data = Compile[{},
     With[{y = Range[-10, 10, .01]},
      Table[Abs@Clip[E^(Sin[x] + Cos[y]) - Sin[E^(x + y)]], {x,
        y}]]][]; // AbsoluteTiming
ArrayPlot[data, ColorFunction -> (Hue[.2, .7, 1 - #] &)]
可是下方多出一部分，而且图形左右颠倒了

---

Clear["`*"];
 data = Compile[{},
      With[{y = Range[-10, 10, .01]},
       Table[Abs@Clip[E^(Sin[x] + Cos[y]) - Sin[E^(x + y)]], {x,
         y}]]][]; // AbsoluteTiming
 ArrayPlot[data, ColorFunction -> (Hue[.2, .7, 1 - #] &)]
这样的话，为什么左右顺序不对，而且还多出一部分

---

ArrayPlot的坐标是按矩阵来的，与Plot之类的函数不一样，要注意转换，自己要多看帮助啊。

---

左右已经调整好了，怎么把x,y均为实数这个条件加进去，试了好久

---

因为上边四个链接画得效果不行~

---

最后再说一次，这四个链接放出来不是让人照抄的。

---

好的 我再仔细研读一下链接里面的代码，希望可以自己做出来

---

那四个链接没有一个提到关键的Interval，而一直在尝试Clip这种错误的处理方法~

---

“关键”的Interval？“Clip这种错误的处理方法”？我可以明着告诉你，用了Interval的那个解法把代码的运行速度足足拖慢了两个数量级。Clip根本就不是这套画法的核心。按按F1把四个链接里的代码读懂会把你们累死？

---

慢是可以优化的，那四个链接早就看过了（在你发之前）。况且性能对比是要在两个正确的方法之间才有意义，一个有缺陷的方法有什么资格来比性能？

---

Sun，你把你的Interval的代码贴一下呗，好想看看

---

@志高，你贴的那段代码就可以改进。grafeq的实质就是区间算术，这四个链接没有一个实现这个核心，都是在用很基本的想法要么取密集点儿，要么就是用数值结果判断，所以效果都很差，越想接近grafeq的效果点就要取得越密集速度也会变慢很多，而且也只能是接近却无法达到，因为数值近似方法本来就有缺陷，比方说UnitStep吧，如果有Abs的话函数值最小只能取到0，那么数值如果取不到使得函数值为0的话就画不出来；而Clip也一样，完全可以构造一个函数能取到足够接近0但从不等于0的，那么结果一样是错误的

---

data = Table[
   With[{a = Interval[{x, x + .025}], b = Interval[{y, y + .025}]},
    IntervalMemberQ[E^(Sin[a] + Cos[b]) - Sin[E^(a + b)],
     0]], {x, -10, 10, .025}, {y, -10, 10, .025}];
ArrayPlot[Boole@Reverse[data, 1]]
这段代码效果不错，但是不知道我问题里的代码该怎么改，你能帮我看看最好了

---

懒得和你们废话了，看编辑。

---

嗯 好的 谢谢吧主，我努力钻研一下你的代码

---

我就说了你这效果太差，根本没得比，而且上边志高贴的那段代码间隔取得太小了，其实取0.05效果已经你这个效果好很多了：
ArrayPlot[
 Reverse@Outer[
     Boole@IntervalMemberQ[E^(Sin[#1] + Cos[#2]) - Sin[E^(#1 + #2)],
        0] &, #, #] &@Table[Interval@{x, x + .05}, {x, -10, 10, .05}]]
这段代码比你那个糟糕的效果的代码只慢5,6倍，而如果自己实现区间运算可以更快，用python实现了下大概快50倍吧，mma又不比python慢，估计差不多也是这个倍数

---

如果在你的审美里，强振荡的部分在图象里必须得糊成一团黑才叫效果好，那我也没什么好说的。

---

不再讨论了，谢谢大家的无私帮助

---

因为这个地方本来就是这么稠密的，你画不出来还有理了？
而且再说你的函数：
equationPlot["approx", 1/10][
 Abs[x + y] + .0001, {x, -10, 10}, {y, -10, 10}, 1/100]
gradEquationPlot[Abs[x + y], {x, -10, 10}, {y, -10, 10}]
第一个不该画出来的画出来（这里当然可以改小approx，但是复杂函数能这么容易看出来approx？），第二个该画出来的没画，这已经不是效果差不差的问题了。

---

稠密的振荡和一马平川的0也是不一样的，把它们画成一样就有理了？上面已经说了，见仁见智的问题。至于你新举的两个例子，如果你这回要拿我在形容自己的代码时用了“通用”两个字说事儿那我也依旧没什么好说的，这里只补充一句"approx"被选为默认方法就是为了多少能规避一点上述问题。最后，Interval方法的优化极限大概是：
With[{step = .05},
  With[{x = Range[-10, 10, step]},
   ArrayPlot[Boole@IntervalMemberQ[E^(Sin[#1] + Cos[x]) - Sin[E^(#1 + x)], 0] &@
       Interval@{#, # + step} & /@ x, DataReversed -> True]]] // AbsoluteTiming

最后的最后，需要指出的是，Interval方法在这个方程上表现得好，其实也是歪打正着，具体原因请参看Interval的自带帮助的“可能存在的问题”。限于精力，本条评论发出后我不会再参与本话题的讨论，其他参与者们请随意。

---

我说的Interval是指算法，而不局限于mma的Interval函数，事实上我是先用python实现的，没怎么优化过，大概也就比你上边所谓的“优化极限大概”快二三十倍吧，也就是比你上边那个所谓的“通用绘图”再快个10倍，不单性能更高，而且不会有你所谓的“可能存在的问题”中的问题，mma完全可以自己实现更加高性能和可靠的区间算数，我这里直接用了interval一方面是为了更清楚的表示算法，一方面也是因为这里用起来正好没问题。

Answer 2

此类图建议使用这个软件绘制：GrafEq，软件的核心算法也是公开的：
http://www.dgp.toronto.edu/people/mooncake/papers/SIGGRAPH2001_Tupper.pdf

在顾森的博客上有简要的介绍，官方网站中不但有详细介绍，还有大量非常漂亮的图片及其对应的函数。

---

由于绘图算法不同，要想用Mma中内置函数实现，计算成本是很高的。
如果有精力，可以参考上面的算法，写一个绘图函数。