Tag Info

Hot answers tagged

8

There exists a simple trick for your purpose, here is my implementation: f[a][b][c][d] //. g_[x_][y__] :> g[x, y] /; (Print[g[x][y] -> g[x, y]]; True) Log[Sqrt[a (b c^d)^e]] //. {Log[x_ y_] :> Log[x] + Log[y] /; (Print[Log[x y] -> Log[x] + Log[y]]; True), Log[x_^k_] :> k Log[x] /; (Print[Log[x^k] -> k Log[x]]; True)} Not as ...


7

Your pattern has itself in its own definition. Mathematica will keep substituting the definition in at each level until it runs out of stack. From this answer about recursive string matching we can see a potential solution: using MatchQ instead of the explicit pattern, since Condition will prevent the recursive part of the pattern from being evaluated when ...


7

Here is how I would do it: expr = 1/((x + a + b) (c + d)); Limit[ ϵ expr /. Thread[# -> ϵ #] &@Select[Variables[expr], # =!= x &], ϵ -> 0 ] (* ==> 1/(c x + d x) *) I replaced all variables except x by ϵ times themselves and took the limit of ϵ times the original expression as ϵ goes to zero. This will leave only terms linear in the ...


6

Re your Idea 2: Both f[s : (_) ..] := Plus[s] f[1,2,3] ( 6 *) and f[s : _ ..] := Plus[s] f[1,2,3] (* 6 *) work as expected. Without space or parentheses separating _ (Blank) from .. (Repeated), both (_..) and _.. are parsed as _. (i.e. Default, which represents an argument that can be omitted - see Default) followed by . which is bad syntax as ...


6

This is quite good: f[d_, n_] := With[{x = Pick[d, Thread[Accumulate[d] - n < 0]]}, Scan[f[x, n - Total[#]] &, Subsets[Complement[d, x], {1, Infinity}]]] f[_, 0] := Throw @ True; weird[n_] := (DivisorSigma[1, n] > 2 n) && ! TrueQ @ Catch @ f[Most @ Divisors[n], n] Select[Range[10000], weird] // AbsoluteTiming (* {1.450002, {70, 836, ...


6

(* Input: Range of even numbers --- Output: Primitive weird numbers *) Block[{$RecursionLimit=Infinity}, subOfSum[ss_, kk_, rr_]:= Module[{s=ss, k=kk, r=rr}, If[ s+w[[k]] >=mm && s +w[[k]] <=m, t=False; Goto[ done](*Found*), If[s +w[[k]]+w[[k +1]] <=m, subOfSum[s +w[[k]], k+1, r-w[[k]]]]; If[s+r -w[[k]] ...


6

One approach would be to first convert the output of N[Sum[1/(10^(n*4) - 1), {n, 1, 100}], 10^2*4] to a String dropping the leading 0. str = StringDrop[ToString@%, 2] Than one can use StringPosition Last /@ StringPosition[str, "0002"]/4 {2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97} An ...


5

The first pattern that came to mind: p1 = {___, 0, Except[0], ___}; ! MatchQ[{2, 3, 17}, p1] ! MatchQ[{2, 3, 17, 0, 0}, p1] ! MatchQ[{1, 0, 1, 0, 1}, p1] True True False I am exploring other avenues now. It seems that this pattern is vastly more efficient that Kuba's superficially similar one. As a simple example: pK = {Except[0] .., (0) ...}; ...


5

Don't reinvent the wheel: If you need a database you should be aware of the SQLite access readily built into Mathematica, though unfortunately undocumented: db = Database`OpenDatabase[FileNameJoin[{$TemporaryDirectory, "mma-temp-db.sqlite"}]]; Database`QueryDatabase[db, "CREATE TABLE stuff(id INTEGER PRIMARY KEY,color TEXT,size REAL,flavor TEXT)" ]; ...


5

Copied from OEIS without thinking about it: Needs["Combinatorica`"] (*then*) fQ[n_] := Block[{d, l, t, i}, If[DivisorSigma[1, n] > 2 n && Mod[n, 6] != 0, d = Take[Divisors[n], {1, -2}]; l = 2^Length[d]; t = Table[NthSubset[j, d], {j, l - 1}]; i = 2; While[i < l && Plus @@ t[[i]] != n, i++] ]; If[i == l, ...


4

exprs = {Power[Subscript[g, a], μ ], Subscript[Power[g, a], α ], Power[g, Times[ρ, θ] ], Subscript[Subscript[g, a], α] } Cases[#, (Power | Subscript)[_, y_] :> y, {0, Infinity}]&/@ exprs (* {{a, μ}, {a, α}, {θ ρ}, {a, α}} *) Update: To get separate lists of powers and subscripts: {powers, subscripts} = Function[{head}, Cases[#, head[_, ...


4

A little more digging resulted in the answer: my pattern is being evaluated to Pi^_*_^_ Using HoldPattern prevents this behavior and gives the expected result: MatchQ[Sqrt[2 Pi], HoldPattern[(_ Pi)^_]] (* True *)


4

There are a few constructs which are not evaluated in the standard way in Mathematica. Unevaluated and Sequence are like this. When Mathematica evaluates an expression, it will first walk through it and strip out any Sequence expressions, leaving only the body. This is a special step done during evaluation. In[]:= On[] f[Sequence[1, 2, 3]] Off[] During ...


4

Finally: test5 = OrderedQ @ Reverse @ Unitize @ # & slow stuff: test = MatchQ[#, {Except[0] .., (0) ...}] & new one, this is "only" two orders of magnitude slower than Mr.Wizard's :) test3 = Length[Split[#, Count[{##}, 0] != 1 &]] <= 2 & getting closer, only twice as long: test4 = Length @ Split @ Unitize @ # <= 2 &


4

I'm not sure about general way, are you concerned of keeping thing unevaluated for example? Are there any Locked heads? Based on Szabolcs suggestion: test = SameQ @@ (Sort //@ {##})& test[ h1[1, h2[3, 2]], h1[h2[2, 3], 1] ] True Or faster modyfication: ord[h_[x__]] := h @@ Sort[{x}]; ord[x___] := x SameQ @@ (ord //@ {h1[h2[2, 3], 1], ...


4

I don't know why Exp[2 I u Sin[x]] /. Exp[Complex[0, a_] u Sin[x]] :> a doesn't work as expected, except that MatchQ[Exp[2 I u Sin[x]], Exp[Complex[0, a_] u Sin[x]]] gives False However, since the apparently more general MatchQ[Exp[2 I u Sin[x]], Exp[Complex[0, a_] u_ v_]] gives True you could use Exp[2 I u Sin[x]] /. Exp[Complex[0, ...


4

For big collections of lists, this should be quick: fx = With[{s = SparseArray[PadRight@#]["AdjacencyLists"]}, SameQ @@@ Transpose[{Length /@ s, Last /@ Replace[s, {} -> {0}, 1]}]] &; Update: Even more so: fx2 = OrderedQ /@ Unitize[#[[All, -1 ;; 1 ;; -1]]] &; Compare (old netbook timings... seems to clobber other answers so far...): (* ...


3

rules = {runBool -> True, linearBool -> True, ab -> 3, linx -> 10}; FilterRules[rules, _?(StringMatchQ[ToString[#], "lin*"] &)] (*{linearBool -> True, linx -> 10}*)


3

rules = {runBool -> True, linearBool -> True, ab -> 3, linx -> 10}; FilterRules[rules, x_ /; With[{z = ToString@x}, StringLength@z >= 3 && StringTake[z, 3] == "lin"]] (* {linearBool -> True, linx -> 10} *) But something like Pick[rules, StringMatchQ[ToString /@ rules[[All, 1]], "lin*"]] is cleaner, IMO, and allows ...


3

I believe that if you want to match a Symbol by its constituent characters that you do need to use string patterns, therefore your solution is reasonable. I recommend a variation: p2 = s_Symbol^_. /; StringMatchQ[SymbolName[s], "V*"] s_Symbol makes sure that the expression that is passed to SymbolName is actually a Symbol. I also find it somewhat more ...


3

Faster however: Timing[n = 1; Reap[While[n < 10000, d = Most@Divisors@n; a = Array[q, Length@d]; If[Mod[n, 6] != 0 && Tr@d > n && Length[FindInstance[a.d == n && (And @@ Thread[0 <= a <= 1]), a, Integers]] == 0, Sow[n]]; n = n + 1];] ] (* {14.188934, {Null, {{70, 836, 4030, 5830, 7192, ...


3

The following is not too slow and uses moderate resources: n = 2; res = {}; Dynamic@n While[n < 10000, d = Most@Divisors@n; a = Array[q, Length@d]; AppendTo[res, Tr@d > n && Mod[n, 6] != 0 && ! SatisfiableQ[Boole@a.d == n, a]]; n = n + 2]; 2 Position[res, True] { {70}, {836}, {4030}, {5830}, {7192}, {7912}, {9272}}


3

This seems like a bug. Additional examples that would need to be explained if it is not: foo[2 I u Sin[x]] /. foo[Complex[0, _] u Sin[x]] :> bar foo[2 I u Sin[x]] /. foo[Complex[0, _] (p : u) Sin[x]] :> bar foo[2 I u Sin[x]] /. foo[Complex[0, _] HoldPattern[u] Sin[x]] :> bar foo[2 I u Sin[x]] bar bar So the problem is unrelated to ...


2

A slighlty different RealDigits approach: N[Sum[1/(10^(n*4) - 1), {n, 100}], 10^2*4]; Partition[RealDigits[%][[1]], 4, 4, -1] ~Position~ {0 .., 2} // Flatten {2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97}


2

In a comment elsewhere, @Mr.Wizard suggested that associations might be useful for this question. Here is my attempt: normalizeAssoc[keys_][l_] := <| l, AssociationThread[keys -> Sort @ Lookup[l, keys, 0]] |> ... and here it is in action: Take[testdata, 2] (* {{h->0.074356,i->0.756409,f->0.456624,b->-0.0342208,c->0.634687, ...


2

I appreciate Jens's answer. However I want to answer literally For example, a sum of several fractions of this form would require isolation of each fraction first, then pattern replacement, then reconstruction of the full expression. Is there a more efficent and general method for this type of replacement/pattern matching? Here are nice functions ...


2

expr = 1/((x + a + b) (c + d)); Based on clipping by total degree. Let me make this answer more general. ClearAll@expand Options[expand] = {"SmallTerms" -> Automatic, "Order" -> 1, "Except" -> {}}; expand[expr_, OptionsPattern[]] := Module[{ t, vars = Fold[ DeleteCases, Flatten[{OptionValue["SmallTerms"]} /. Automatic -> ...


2

ClearAll[f1,f2] f1 = With[{u = Unitize@#}, FreeQ[u[[;; Tr@u]], 0]] &; f1 /@ {{1, 2, 3}, {0, 1, 2, 3, 0}, {1, 2, 3, 0, 0, 0}, {0, 0, 1, 2, 3}} (* {True, False, True, False} *) f2 = With[{u = Unitize@#}, Times @@ N @ u[[;; Tr@u]] != 0] &; f2 /@ {{1, 2, 3}, {0, 1, 2, 3, 0}, {1, 2, 3, 0, 0, 0}, {0, 0, 1, 2, 3}} (* {True, False, True, False} *)


1

expr = Series[E^(x/v), {v, Infinity, 3}] // Normal; (* gen some Ds *) t = Table[Assuming[j ∈ Integers, D[expr, {v, j}]], {j, 1, 10}]; (* get the pattern...*) seq = FindSequenceFunction[t /. v -> 1, FunctionSpace -> All] (* spot check some results...*) yours = (-1)^j*(j! x + (j + 1)! (x^2)/2 + (j + 2)!*(x^3)/12); SameQ @@@ Table[{yours /. j -> z, ...


1

Instead of using replacement rules or pattern matching, I would extract the coefficients directly: Total@MapIndexed[#1 m[First@#2 - 1] &, CoefficientList[ns, z]] This extracts a list of the coefficients of the powers of z in ns, then multiplies each one of them by m[n] (I subtract one since index 1 corresponds to m[0]), finally totaling all the terms ...



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