# Tag Info

20

The engine behind this inside Compile is a well-hidden function called OptimizeExpression. it has two levels, 1 and 2. Setting to 2 makes it work harder to find CSEs. e1 = (G u^2 (6 p (2 h + p) - 8 (h + p) u + 3 u^2))/(12 h^2); e2 = (G (3 h + 3 p - 2 u) u^2)/(3 h^2); Experimental`OptimizeExpression[{e1, e2}, OptimizationLevel -> 2] (* Out[40]= ...

8

Since we can consider $f$ as a $4-$th order polynomial (with respect to $y$) we can always factorize it as you claim in terms of radicals, but for the sake of simplicity let's start writing it symbolically in terms of the Root objects defining $f$ to be p[x,y]: p[x_, y_] := x^9 - x^6 + 4 x^5 y + 2 x^3 y^2 - y^4 pf[x_, y_] = -Times @@ (y - (y /. {ToRules @ ...

7

My lucky day (night). I get to take my own answer which was of dubious value here and basically repurpose it to give a good response to this question. We set this up as a mixed linear program by trying to get sums of logs of factors as close to m as possible, subject to coefficients being nonnegative integers that do not exceed the powers of the ...

6

Since you are going to work with numeric functions, Compile will optimize your functions along those lines. If you define : f = Compile[{{g, _Real}, {u, _Real}, {h, _Real}, {p, _Real}}, {(g u^2 (6 p (2 h + p) - 8 (h + p) u + 3 u^2))/(12 h^2), (g (3 h + 3 p - 2 u) u^2)/(3 h^2)} ] you can already see some of it in the output. To get an even more in ...

6

By default Mathematica can factorize polynomials to lower order ones in terms of integers if it's possible. Extension serves factorization over the rationals extended by a finite set of algebraic numbers, i.e. any element of the extension is a finite combination of rationals and algebraics $(a_1, a_2,...,a_n)$. The fundamental theorem of algebra states that ...

5

Level may provide a means of getting started. Level breaks down your polynomials into their constituent parts, with various "levels" of complexity. As @Rex Kerr noted in a comment, Level 1 happens to be interesting in the present example. a=(G u^2 (6 p (2 h+p)-8 (h+p) u+3 u^2))/(12 h^2); b=(G (3 h+3 p-2 u) u^2)/(3 h^2); ...

5

A function from the article that cormullion linked is shorter and faster than what I proposed below. Transcribed in terse style: uf[m_, 1] := {{}} uf[1, n_] := {{}} uf[m_, n_?PrimeQ] := If[m < n, {}, {{n}}] uf[m_, n_] := uf[m, n] = Join @@ Table[Prepend[#, d] & /@ uf[d, n/d], {d, Select[Rest@Divisors@n, # <= m &]}] uf[n_] := uf[n, n] ...

5

First, set the option of Roots so that it doesn't expand quartics. Optionally, define a Format for Root. SetOptions[Roots, Quartics -> False]; Unprotect[Root]; Format[Root[func_, v_], StandardForm] := Row[{"eq", "(", v, ")"}]; Protect[Root]; a1 = Roots[x^4 + r1 x^3 + r2 x^2 + r3 x + r4 == 0, x][[1]][[2]]; a2 = Roots[x^4 + r1 x^3 + r2 x^2 + r3 x + r4 ...

4

More concise, but same idea as in Artes' approach (which I upvoted, but I'm adding this anyway because it won't squeeze into a comment). factorCompletely[poly_, x_] := Module[ {solns, lcoeff}, solns = Solve[poly == 0, x, Cubics -> False, Quartics -> False]; lcoeff = Coefficient[poly, x^Exponent[poly, x]]; lcoeff*(Times @@ (x - (x /. solns))) ...

4

This is a variant on the suggestion by @Artes. We start by defining a set of substitutions, using some new variables. Create a Groebner basis. Not to worry if that's not a familiar concept, suffice it to say that we use it for purposes of algebraically rewriting polynomials. The thing to know is that the old variables are to be given greater priority than ...

4

Here's a way to brute-force search for numbers that have the property that the sum of the digits raised to an integer power is equal to the number itself. list = {}; Do[If[Total[IntegerDigits[b^e]] == b, AppendTo[list, {b, e}]], {b, 2, 800}, {e, 2, 100}]; This returns a list of the numbers and powers (here's just the first 50), ordered so that they ...

4

Assuming only integers will be input to squareFreeQ. Your squareFreeQ as defined in the question does not return True or False as does the built-in SquareFreeQ. Rather your function returns a list of exponents, if any, which are greater than one. Hence, after selecting exponents exceeding 1, compare the list to {}, which occurs for squarefree numbers. The ...

3

Not sure if this is what you are after but maybe if its not it will help you clarify the question: long = RandomInteger[10^30]; base = 2^32; repr = IntegerDigits[long, base]; Total@MapIndexed[ #1 base^(First@#2 - 1) &, Reverse@ repr] == long StringJoin[ MapIndexed[ If[First@#2 > 1, "+", ""] <> ToString[#1 ] <> Table[ ...

3

Here's a semi-manual method of simplifying solutions by creating our own substitutions. As a more manageable example, let's start with the solution to the cubic: cube = Solve[a x^3 + b x^2 + c x + d == 0, x] Here's just the first root (TeXForm[x /. cube[[1]]]): $\frac{\sqrt[3]{\sqrt{\left(-27 a^2 d+9 a b c-2 b^3\right)^2+4 \left(3 a ... 3 a) We can pass through the first half of the list of divisors to avoid duplicating factors. There are many possible ways to proceed, let's mention a few of them : f1[n_] := {#, n/#} & /@ First @ Partition[ #, Ceiling[ Length[#]/2] ] & @ Divisors[n] or f2[n_] := Module[{k, l}, k = Divisors @ n; l = Length @ k; ... 3 For part (b) of your question, there is a built-in function: IntegerPartitions[12, {2}] (* {{11, 1}, {10, 2}, {9, 3}, {8, 4}, {7, 5}, {6, 6}} *) For the last part, deDup1 = DeleteDuplicates[#, #1 == Reverse@#2 &] &; (* or *) deDup2 = DeleteDuplicates[#, Union@#1 == Union@#2 &] &; deDup1@Function[int, {#, int/#} & /@ ... 3 Quote from MSieve (one of the more popular factorization programs): On a fast modern CPU, a 110-digit QS factorization takes nearly 120 hours for Msieve. A 100-digit one should be significantly less than that. So, no, it does not take 100 years. The trouble you are having fitting your data is not that there are too few points, but the distribution of ... 3 rand := RandomInteger[{-10, 9}] /. (0 -> 10) eq := rand x^2 + rand x + rand Array[eq &, {25}] {5 - 3 x - 6 x^2, -9 - 6 x + 5 x^2, -2 - 6 x + 9 x^2, 7 - 6 x + 9 x^2, 2 + 8 x + 8 x^2, 3 - x + 5 x^2, -10 + 4 x - 5 x^2, -4 + 6 x + 10 x^2, 2 - 5 x - 5 x^2, -7 - 2 x - 8 x^2, -7 - 4 x - 6 x^2, -1 - 2 x + 7 x^2, 8 - 2 x + x^2, 5 + 2 x + ... 3 Here's a slightly different method. Except for the fact that you want non-zero integers, RandomInteger would be perfect for this, e.g. len = 5; RandomInteger[{-10, 10}, {len, 3}] (* {{-3, -2, 10}, {2, -3, -8}, {5, 3, -2}, {9, 3, -2}, {-9, 3, -6}} *) which gives your list of triples directly. Now, you could alter the range and make substitutions like Yi ... 2 It looks like your resulting expression will have a unit coefficient for the highest power. In this case you can do : expr = Times @@ (s - Solve[LP2nTfDen/Last@CoefficientList[LP2nTfDen, {s}] == 0, s][[All,1, 2]]) ; expr == LP2nTfDen/Last@CoefficientList[LP2nTfDen, {s}] // Simplify (* True *) 2 Brute-forcing for "small" n: nrstDvsrsF = Nearest[Divisors[#1], #2, 2] & nrstDvsrsF[720, 8] (* {8, 9} *) nrstDvsrsF[720, 20] (* {20, 18} *) AbsoluteTiming[nrstDvsrsF[20!, 1*^9]] (* {0.031003, {999949860, 1000194048}} *) AbsoluteTiming[nrstDvsrsF[30!, 1*^9]] (* {14.320432, {999949860, 1000065000}} *) Warning: As noted by @whuber in comments, ... 2 Because $$3\sin^2 x - 3\cos x -6\sin x + 2\sin 2x + 3 = (\cos x - 1)P(x)$$ then $$P(x) = \frac{3\sin^2 x - 3\cos x -6\sin x + 2\sin 2x + 3}{\cos x - 1}$$ I think you can just simplify this expression in Mathematica: FullSimplify[( 3 - 3 Cos[x] - 6 Sin[x] + 3 Sin[x]^2 + 2 Sin[2 x])/(-1 + Cos[x])] -6 - 3 Cos[x] + 2 Cot[x/2] + 4 Sin[x] then$\$P(x)=-6 - ...

2

I don't exactly know what I'm doing, but...here is an outline using Smith's method to recast a number as a sum of squares. the overall approach is this. (1) Factor into ordinary primes. (2) For each ordinary prime p, factor over Z[sqrt(-3)]. (3) Now replace sqrt(-3) with 2ω+1. Clearly (1) and (3) are straightforward in Mathematica. For (2) one can do as ...

2

Here is a rough way to achieve this: RandomPolynomial[max_Integer, var_Symbol] := Module[{pol, lis}, lis = Table[RandomChoice@Join[Range[-10, -1], Range[10]] var^deg, {deg, max,0, -1}]; pol = Tr@lis] Now let's create 25 of these: Table[RandomPolynomial[2, x], {25}]

1

I'm not sure if this is what the prof was thinking, but your function is not the same as the built-in function. Here are four cases. squareFreeQ := Select[Last /@ FactorInteger[#], # > 1 &] &; {squareFreeQ[#], SquareFreeQ[#]} & /@ {10, 12, x^4 - 1, x^4 - 2 x^2 + 1} They agree on the first two, but your function throws errors on the final ...

1

The quintic Once upon a time I tried to understand Galois work in order to understand what specific equations of a given degree admit an algebraic solution... (Its ending was, that I started to think that the ingrain wallpaper of my study room was actually braille :) ... my desperate attempt of humour aside) I can't solve your specific problem, but what I ...

1

Maybe too late to join the party, but here's is my implementation for squareFreeQ. We know that a number is square-free, if its prime decomposition contains no repeated factors. Also we've to take into account, that 1 is by convention squarefree. We can list the first squarefree numbers using: Select[Range[20], Max[Last /@ FactorInteger[#]] < 2 &] ...

1

The function squareFreeQ returns the exponents of factorization where as the the function SquareFreeQ is boolean, returning true if there are no square factors, viz al exponents are 1. Although the following does not use Select it can perhaps be motivation for desired solution: squarefreeq[u_] := And @@ (#[[2]] == 1 & /@ FactorInteger[u]); Testing: ...

1

I think that @KennyColnago is right, you need to make sure you return True or False. Additionally, in the last sentence in part A your prof is pointing out that you should use an option to make sure Select quits the routine as soon as a power is found, thus you can (and possibly should) use the third argument (strictly speaking not an "option") of Select: ...

1

poly = 6 x^3 + x^2 y - 11 x y^2 - 6 y^3 - 5 x^2 z + 11 x y z + 11 y^2 z - 2 x z^2 - 6 y z^2 + z^3; Factor[poly] sol = Solve[poly == 0, z] d = Directive[Opacity[.7], Specularity[White, 60]]; Plot3D[z /. sol, {x, -1, 1}, {y, -1, 1}, Mesh -> None, PlotStyle -> {{d, Red}, {d, Green}, {d, Blue}}, Evaluated -> True]

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