15

Here is a "homotopy style" transformation between functions $h(x, q) = (1-q) f(x) + q g(x)$. (* set initial data points *) ClearAll[x] ; x = Subdivide[-1, 1, 14] ; (* replace x^2 with q/2 + (1-q) x^2, i.e q = 0 -- initial function, q = 1 -- final function (line) *) ClearAll[fun]; fun[q_][x_] := 0.5*q + (1.0 - q)*x^2 ; (* arc length *) ClearAll[...


13

The arclength is given by this and is the big expression containing ArcSinh later on: Integrate[Sqrt[1 + (2 a x)^2], {x, -k, k}, Assumptions -> a > 0 && k > 0] For a given a and len (arc length) find the best k (integration range) that gives that length by doing an NMinimize (for whatever reason, NSolve didn't work that well so I ...


11

As others have pointed out alternative methods to get the desired result, I'll address the why of the matter. The difference stems from a two-step cascade, the first being computational and the second, mathematical. We can see the first step with the use of Trace. Power[t^2, (3)^-1] /. t -> -0.5 // Trace t^(2/3) /. t -> -0.5 // Trace {...,{(-0.5)^2, ...


9

You can redefine your function f to accept a variable number of arguments (x__) and then check the length with Length. Clear[f]; f::argerr = "Two arguments expected, but `1` given."; f[x__] := If[Length@List@x == 2, List@x, Message[f::argerr, Length@List@x]; $Failed]; f[1, 2] (* {1, 2} *) f[1, 2, 3] (* f::argerr: Two arguments expected, ...


9

f[t_] = t^2; {l, u} = {-1, 1}; To transition to a line, curves that preserve the arc length and scales the signed curvature by q are used. First such curves are made for a variety of q values: sols = <|# -> First[{x, y} /. NDSolve[##2]] & @@@ Table[Evaluate[{1 - q, {D[x'[t]^2 + y'[t]^2 == Total[D[{t, f[t]}, t]^2], t], (x'[t] y''[t] - y'[t] x''[...


6

Module does lexical scoping. That means that only the ms that are literally inside the module when it is evaluated are bound to the m of the module, other ms outside of the Module are unaffected (this is effectively done by replacing all occurrences of m in the body of the Module with a localized name like m$1234, which is then set to 1). In your case, the ...


5

FunctionRange[{-a* Log[1 - (a - a E^(-1 - 1/a + ProductLog[E^(1 + 1/a)]))/a], a > 0}, a, y] 5.14988*10^-9 <= y <= 0.5 and warming message: Unable to find the exact range. Returning bounds on the range computed using numeric optimization methods So we have to consider Derivative FunctionRange[{D[-a* Log[1 - (a - a E^(-1 - 1/a + ...


5

It is useful when your pattern does not start with _. Suppose your pattern is a list of integers, total[list : {__Integer}] := Total[list] total[___] := $Failed Or a variable that can be true or false: func[arg:(True | False)] := If[arg, foo, bar] func[___] := $Failed


5

In the following simplistic benchmark, passing a single argument-list g[{x1,x2,x3,...,xn}] is about 100×–1000× faster than passing arguments separately f[x1,x2,x3,...,xn] when using large numbers of arguments: f[x__] := Total[{x}] (* slow: call as f[x1,x2,x3,...,xn] *) g[x_] := Total[x] (* fast: call as g[{x1,x2,x3,...,xn}] *) SeedRandom[...


5

{Plot[1 - Power[t^2, (3)^-1], {t, -1, 1}], Plot[1 - Surd[t, 3]^2, {t, -1, 1}]} Or {Plot[1 - Power[t^2, (3)^-1], {t, -1, 1}], Plot[1 - CubeRoot[t]^2, {t, -1, 1}]}


4

Clear[a, x, y, x1, x2] SeedRandom[2] npts = 200; r = 3; pts1 = RandomReal[{-1.5, 1.5}, {npts, 2}]; parms = {a -> 1/2, b -> -1/2}; f[x_, y_] := y - a x^2 - b /. parms px[x_] := 1/2 x Sqrt[1 + 4 a^2 x^2] + ArcSinh[2 a x]/(4 a) /. parms vecn = Grad[f[x, y], {x, y}]; GRS = {}; INTS = {}; For[k = 1, k <= npts, k++, {x0, y0} = pts1[[k]]; equs = Join[...


4

Phew, this is quite a long and dense code, so I can give only some general hints. First you should look where the actual bottlenecks are. Please do not expect this from members of this forum. Anyways, here are some spots to look: The code throws many General::munfl errors because you feed the exponential functions with many negative values of large magniture....


3

This may be helpful: x = 4 + m; g = Sin[x]; Module[{m = 1}, Evaluate[g]] The output is Sin[5]


3

Set up a test function to control the iteration: Clear[test, i] i = 1; test[i_] := Max[Sow[RandomInteger[{1, 20}, i]]] >= 15; Use Sow-Reap combo to collect the results generated during the iteration, where SeedRandom is used to make the random results appear determined for the purpose of demonstration: SeedRandom[23]; Reap[While[test[i], i++]][[2, 1]] {{...


3

Method 1 Here we plot the intersection of three functions g[8,pc], g[10,pc], g[20,pc] respect tof[pc]. For example,if we want to find the intersetion of g[8,pc] and y=f[x] when we plot g[8,pc], we can set the MeshFunction of g[8,pc] to y-f[x],that is MeshFunctions -> {#2 - f[#1] &}, Mesh -> {{0}} np = 2; f[pc_] := 1; q[d_, pc_] := (pc/(100*0.48))...


3

np = 2; f[pc_] = 1; dmin = 8; dmax = 24; dincr = 4; q[d_, pc_] = (pc/(100*12/25))* Sum[((Pi/4)*(d - (2*n*12/25))^2), {n, 1, np}] // Simplify; p[d_] = Sum[Pi*(d - (2*n - 1)*12/25), {n, 1, np}] // Simplify; g[d_, pc_] := q[d, pc]/p[d]; pt[d_] = {pc, f[pc]} /. Solve[g[d, pc] == f[pc], pc][[1]]; Plotting Plot[{ Evaluate[Table[g[d, pc], {d, dmin,...


3

Limit[v[a], a -> 0, Direction -> -1] (* 0 *) Limit[v[a], a -> Infinity] (* 1/2 *) NMaximize[{v[a], a > 0}, a, WorkingPrecision -> 100] (* {0.4999999999999999999999999999999996695802781800686528047791793409305\ 917941358131704720756957033359931, {a -> 1.89153358206810035345892896405454026939268176767953621670767804301\ ...


2

Here are two versions of the same solution. First, using a general 2x2 matrix along the subdiagonal ClearAll[v] v[Nm_] := Block[{array, band}, array = With[{mat = Normal@SparseArray[Band[{2, 1}] -> Array[band, Nm - 1], Nm]}, ArrayFlatten[mat /. {0 -> ConstantArray[0, {2, 2}], band[n_] :> n{{b11, b12}, {b21, b22}}}]]; (array + ...


2

I don't know why the first case does not through an error, but SparseArray expectes the correct dimensions of the array as second argument. So V0 should read as follows: V0[Nm_] := SparseArray[{ Band[{3, 1}] -> Table[V[n], {n, 1, Nm - 1}], Band[{1, 3}] -> Table[ConjugateTranspose[V[n]], {n, 1, Nm - 1}] }, {2 Nm, 2 Nm} ]; The result ...


2

Big advantage of Mathematica is that you can almost literally write your thoughts f[x_ /; -1 <= x <= 1] := 1 f[x_ /; x > 1] := 0 f[x_ /; x < -1] := 0 After defining your function, you can plot or do whatever with it Plot[f[x], {x, -3, 3}] You can also combine the conditions, for instance f[x_ /; x < -1||x > 1] := 0 use Piecewise use ...


2

Another possibility is to use new in M12 function AsymptoticSolve: sol = AsymptoticSolve[y==f[r],y,{r,Infinity,4}] {{y -> (-8 r^3 + 12 r^2 Log[4 (2 \[Pi])^(1/3)] - 18 r Log[4 (2 \[Pi])^(1/3)]^2 + 27 Log[4 (2 \[Pi])^(1/3)]^3)/(8 r^4)}} Compare to Vaclav's answer: Series[y /. First @ sol, {r, Infinity, 4}] //TeXForm $-\frac{1}{r}+\frac{3 \log \left(4 \...


1

$Version (* "12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)" *) Clear["Global`*"] eqns = {(4.566810^(-3)) ((2.71828^(-1.5812 x + 0.000599221 y))* Cos[(-0.000599221)*Log[2.71828] x + (-1.5812)* Log[2.71828] y] + (2.71828^(-1.5812 x - 0.000599221 y))* Cos[(0.000599221)*Log[2.71828] x + (-1.5812)* ...


1

Essentially you are asking if Function[{x1, x2}, f[x1, x2]] [x1, x2] is better in some sense than Function[x, f[x[[1]], x[[2]]]]@ {x1, x2} with respect to optimizing speed, memory, and coding "safety". With regard to speed and memory, it is possible to test performance with controlled experiments. With regard to coding "safety", that is ...


1

Here is an alternative approach. This generates empty list most of the time since first number might be less than 15 more often. SeedRandom@134 list = TakeList[RandomChoice[Range@20, 10000], Range@100]; TakeWhile[list, Max@# >= 15 &] {{19}, {4, 18}, {10, 11, 18}} Let see next list Take[list, 4] {{19}, {4, 18}, {10, 11, 18}, {3, 6, 5, 7}} Here is ...


1

When Series is not applicable, we can use a cycle of Limits fun = f[r] (* for f[r] see above *); ser = 0; c = 0; Do[fun = (fun - c)*r; c = Limit[fun, r -> Infinity]; ser += c/r^k, {k, 1, 4}]; Print[ser] We get an asymptotic expansion with more terms $$-\frac{1}{r} + \frac{\log (128 \pi )}{2 r^2} - \frac{9 \log ^2\left(4 \sqrt[3]{2 \pi }\right)}{4 r^3} + ...


1

What about Apart[(8 z^2)/(8 z^2 - 6 z + 1) /. z -> 1/zi, zi] /. zi -> 1/z (*4/(-4 + 1/z) - 4/(-2 + 1/z)*)


1

As an alternative you could use Fold Diffn1[f_, x_Symbol, n_Integer?Positive] := Fold[D[#1, {x, #2}] &, f, Range[n, 1, -1]] Diffn1[f[x], x, 3] (* Derivative[6][f][x] *) Or it can be simplified as Diffn2[f_, x_Symbol, n_Integer?Positive] := D[f, {x, n (n + 1)/2}] These are equivalent And @@ Table[Diffn1[f[x], x, n] == Diffn2[f[x], x, n], {n, 1, 20}]...


1

(* get our operators like this: *) n=3; operators = Array[Function[{y}, D[y, {x, #}]] &, n] (** returns: {Function[{y}, D[y, {x, 1}]], Function[{y}, D[y, {x, 2}]], Function[{y}, D[y, {x, 3}]]} **) (* Apply composition to put them together *) composed = Composition@@operators; (* try it out: *) composed[x^6] (* 720 *) (* verify it matches this ...


Only top voted, non community-wiki answers of a minimum length are eligible