Mathematica 有什麼奇技淫巧？

01-07

可以看看我的這篇博文裡面涉及的代碼，用不到四十行（如果壓縮行數會更少）代碼寫一個和mathematica完全融合的LISP解釋器。這是明天下午在科大Mathematica講座的備課內容，乾脆貼這裡了。

裡面實現了一些基本功能，包括函數定義，純函數定義，和LISP最最重要的宏定義，完成了上面這幾部分，實際上可以寫出任意一個lisp的變種。而且獨特的優勢是可以直接調用Mathematica內置的科學計算函數。

其實Mathematica語言本來就是LISP變種啦。

用mathematica寫一個LISP解釋器

這四十行代碼滿滿的都是mathematica的奇技淫巧。比如用這種語句來畫圖

{Plot,Sin[x], {x, 1, 100} }

混合風格

雖然這並不是常見的lisp語法，比如圓括弧，比如quote，但是本質在這裡了。。

快點贊快點贊，我寫了一個晚上。

代碼看不懂的也要點贊我才有動力寫詳細解釋。

一些函數的不太常見的用法，運行後出結果，就不用解釋了吧

Range[{1, 2}, 10, 2] MapAt[F, Range[10], ;; ;; 2] Table[If[i &< 5, i, Unevaluated[]], {i, 10}] Graphics[{Antialiasing -&> False, Circle[]}] Internal`PartitionRagged[Range[11, 20], {2, 3, 5}] Random`Private`MapThreadMin[{{2, 3, 4, 8}, {1, 5, 2, 5}}] PolynomialForm[5 - 2 x + x^2 - 4 y + y^2, TraditionalOrder -&> True] Plot[Sum[Sin[(2k-1)x]/(2k-1),{k,1,Range[5]}],{x,0,4Pi},Evaluated-&>True]

Position算得上常用的內置函數，但是速度並不快，還不如用SparseArray的NonzeroPositions

list=RandomInteger[100,10^6]; r1=Position[UnitStep[list-50],0];//AbsoluteTiming r2=SparseArray[UnitStep[list-50],Dimensions@list,1]["NonzeroPositions"];//AbsoluteTiming r1==r2

Solve和Reduce可以消去變數，只求解感興趣的未知數，有時比較有用，比如可以加快某些複雜方程組的求解速度，Solve的文檔里居然沒有提這種用法，不過這裡有，tutorial/EliminatingVariables

Solve[{x + y == 7, x y == 12}, x, {y}] Solve[{x+y+z==a,x^2+y^2+z^2==b,x^3+y^3+z^3==c,x^4+y^4+z^4==d},d,{x,y,z}]

儘可能地少用 "[[i]]

Compile[{},Select[Permutations@Range[9],#[[1]]/(10#[[2]]+#[[3]])+#[[4]]/(10#[[5]]+#[[6]])+#[[7]]/(10#[[8]]+#[[9]])==1]][]

With[{f=#/(10#2+#3)+#4/(10#5+#6)+#7/(10#8+#9)==1/.Slot@i_:&>#[[i]]},Compile[{},Select[Permutations@Range[9],f]]][]

一些亂七八糟東西的集合，可能有一點點微小的用處。

1 Charting`padList a = {1,Pi,2+3I,{1,2},{3,4},-2} Charting`padList /@ a


2

Graphics`Mesh`MeshInit[];

pp = PolarPlot[Sqrt[ 4 Sin[[Pi] x]^2 + x^2 Tan[[Pi]/180]^2], {x, 0, 360}];

intersections = Graphics`Mesh`FindIntersections[pp];

Show[pp, Epilog -&> {Red, PointSize[Large], Point@intersections}]
3.

A = Graphics@(Line /@ RandomReal[1, {2, 2, 2}])

Graphics`Mesh`IntersectQ[A]
4

polys = {Polygon[{{1, 3}, {3, 4}, {4, 7}, {5, -1}, {3, -3}}],

Polygon[{{2, 2}, {3, 3}, {4, 2}, {0, 0}}]};

Graphics[Append[{Gray, polys}, {Blue,

Graphics`PolygonUtils`PolygonIntersection[polys]}]]

(*In Old version :Graphics`Mesh`PolygonIntersection[]*)
5

Internal`PartitionRagged[Range[11, 20], {2, 3, 5}]

Random`Private`MapThreadMin[{{2, 3, 4, 8}, {1, 5, 2, 5}}]
6

GeometricFunctions`BinarySearch[Range[10], #]  /@ {1, 5, 8, 3.2, 3,

  3.5, 3.6, 0.1, 100, 10, 10.1}
7

pts = RandomReal[{-5, 1}, {10^4, 2}];

pts2 = Select[pts, #[[1]]*#[[2]] &<= 5 ];
Show[ListPlot[pts2], ListLinePlot[SortBy[Internal`ListMin[pts2], First], 
PlotStyle -&> Directive[Bold, Red]]]
8

dataReal = ToString /@ RandomReal[1000, {10^5}];

d1 = Internal`StringToDouble /@ dataReal; // AbsoluteTiming

d2 = ToExpression /@ dataReal; // AbsoluteTiming

d1 == d2
9

Internal`CompareNumeric[0.1, 2.00001, 2]

Internal`CompareNumeric[prec, a, b] returns -1, 0, or 1 according to whether a is less, equal, or greater than b when compared

at the precision of a or b (whichever is less) minus prec decimal digits of "tolerance".
10

f[z_] := Piecewise[{{0, 0 &< z &< 30}, {1, 30 &< z &< 60}, {0, 
    60 &< z &< 120}, {-1, 120 &< z &< 150}}]

Simplify`PWToUnitStep@f[z]
FullSimplify[%]
appro = With[{k = 1000}, Tanh[k #]/2 + 1/2 ];
unitStepExpand = Simplify`PWToUnitStep@PiecewiseExpand@# ; 
unitStepExpand@Which[a &> 1, 5, 1 &<= a &< 2, 6, True, 7] /. 
 UnitStep -&> appro
11

Hold[{1, 2, 3, 4, 5}] /. n_Integer :&> RuleCondition[n^2, OddQ[n]]

(*Hold[{2.,3.}]/.n_Real[RuleDelayed]With[{eval=n^2},eval/;True]

Hold[{2.,3.}]/.n_Real[RuleDelayed]Block[{},n^2/;True]*)
12

{c, v} = GroebnerBasis`DistributedTermsList[

  2 x^3 + 3 x^(-2) y + 4 x y^2 - 5 y^(-3) + 1]

Transpose@{Transpose[

   c[[All, 1]].Replace[v, {# -&> 1, 1/# -&> -1, _ -&> 0}, 1]  /@

    Variables[v]], c[[All, 2]]}
(*function[eq_]:=CoefficientRules[eq/.Power[a_,b_?(#&<0)][Rule]Power[
a,-10^10 b]]/.a_?(#&>10^9)[Rule]-a/10^10
function[2 x^3+3 x^(-2) y+4 x y^2-5 y^(-3)+1]*)
13

poly = Polygon[Table[{Cos[t], Sin[t]}, {t, 0, 4 [Pi], (4 [Pi])/5}]]

Graphics`Mesh`MeshInit[]

poly2 = PolygonCombine@SimplePolygonPartition@poly

Graphics[{EdgeForm[Black], Yellow, poly2}]

14 &<&< ComputationalGeometry` n = 10; a = RandomPoint[Disk[], {n, 4}] ConvexHull /@ a 15 Needs["Combinatorica`"] Select[SetPartitions[7], Length@# == 2 ] KSetPartitions[7, 2] FerrersDiagram[RandomPartition[100]] 16 m = {{1, 1, 1, 1}, {1, 1, 1, 1}, {1, 1, 1, 1}, {1, 1, 1, 1}}; diag = ConstantArray[1, Length[m]]; LinearAlgebra`AddVectorToMatrixDiagonal[m, diag] 17 list={"-0.04%", "7.56%", "0.28%", "2.81%", "-0.35%", "-1.45%", "-1.05%"} res = Internal`StringToDouble /@ list/100; 18 AbsoluteTiming[ data = Table[{RandomReal[{0, 10}, 2], RandomReal[{1/4, 1}]}, 50]; disks = DeleteDuplicates[Disk @@@ data, Not@*Region`AlmostDisjointQ@*List]; Graphics[{Circle @@@ data, Opacity[0.2], disks}]] 19 MathLink`CallFrontEnd[FrontEnd`UndocumentedCrashFrontEndPacket[]]

See this trick:

rule = { q_[x_] /; Length[StringSplit[ToString[q], ""]] &> 1 StringSplit[ToString[q], ""][[1]] == "d" :&> Module[ {l = StringSplit[ToString[q], ""], sl}, sl = Length[Split[l][[1]]]; If[sl == Length[l], sl = sl - 1]; D[ToExpression[StringJoin[l[[sl + 1 ;; -1]]]][x], {x, sl}]] };

With this, you can do tricks like:

In[] = dSin[x] /. rule Out[] = Cos[x]

and

In[] = dddddLog[t] /. rule Out[] = 24/t^5

In general, an input "ddd...dddf[x]" will be interpreted as the n-order derivative of the function f[x]. However, x must be a symbol, not an expression; i.e. "dddSin[5x]" does not work because 5x is an expression, not a symbol.

This is not a useful trick, but it does demonstrate an interesting feature of MMA.

求a和絕對值b的和：sumofaandabsb[a_, b_] := If[b&>0, Plus, Subtract][a, b]

還有，一個通用的既可以把數乘以2，又可以把字元串擴展一倍連接在一起的double函數：

double[v_] := If[StringQ[v], StringJoin, Plus][v, v];

如果運行double[5]得到10，如果運行double["hello"]得到"hellohello"

瀏覽一下 https://twitter.com/mathematicatip。