New answers tagged

2

Clear[arrayH] arrayH[n_Integer] := Partition[ Flatten[Array[H, {n + 1, n + 1, n + 1, n + 1}, {0, 0, 0, 0}]], (n + 1)^2 ] arrayH[3] Then define an appropriate function H that calculates the value of each item using the indices. By way of example, if you had defined a function: Clear[H] H[i_, j_, k_, l_] := StringJoin @@ (ToString /@ {i, j, k, l}) ...


2

makeBrackMat[mat_?MatrixQ] := DisplayForm[ RowBox[{StyleBox["[", SpanMaxSize -> \[Infinity]], GridBox[mat], StyleBox["]", SpanMaxSize -> \[Infinity]]} ] ]; Exact numbers: mat1 = Partition[Range[12], 3]; makeBrackMat[mat1] Machine-precision numbers: mat2 = {{1.3, 2.9}, {9.5, 8.4}, ...


2

The answer is as you suspect - when you evaluate Dot[m1, m2, m3, m4, m5, ......m1000] the process is something like this: Look at the input: Dot[m1, m2, m3, m4, m5, ......m1000] Evaluate the first matrix product, m12=m1.m2 Look at the input: Dot[m12, m3, m4, m5, ......m1000] Evaluate the first matrix product, m123=m12.m3 Look at the input: Dot[m123, m4, ...


4

Your cube file had a very large grid ( 117*117*130 = 1779570), and 2 million points is just far too many for testing a function. So I created cube files for the electron density and electrostatic potential for the molecule furan, using a much sparser grid (around 8000 grid points instead). Here they are: Density cube file Potential cube file Now that ...


1

ClearAll[fn2] fn2 =With[{cp = #1, p = Position[#2, #2[[## & @@ #]]]}, MapAt[0 &, #2, Select[p, ChessboardDistance[#, cp] <= 1 &]]] & Row[MatrixForm /@ {board, fn2[{3, 3}, board], fn2[{3, 4}, board]}]


3

Array size/shape agnostic, takes care of edge cases automagically, call with player identifier, position, and current array, returns changed array: fn = With[{cv = #1, cp = #2, cm = #3}, ReplacePart[cm, Select[Position[cm, cv], ChessboardDistance[#, cp] <= 1 &] -> 0]] &; Use example: fn[a, {5, 3}, mat]


1

Completely different approach, so I'm making it a separate answer: board[[row - 1 ;; row + 1, col - 1 ;; col + 1]] = board[[row - 1 ;; row + 1, col - 1 ;; col + 1]] /. clicked -> 0; This has the advantage of only updating the neighbourhood of the clicked cell instead of mapping a function over the entire grid. I also think it's quite clear and ...


2

Here is one way to do it, although I feel like there is probably an even more elegant solution: MapIndexed[ If[ # === clicked && ChessboardDistance[#2, {row, col}] <= 1, 0, # ] &, board, {2} ] E.g. with row = col = 4 on your above example you'd get: {{0, 0, 0, 0, 0, 0}, {0, a, a, b, 0, 0}, {0, a, 0, b, 0, 0}, ...


2

Perhaps this, which converted to exact fractions trying to avoid roundoff errors: {ToRules[N[Reduce[Simplify[{vals[[3]]/vals[[1]] == ((112/100)/(1735/10)), vals[[2]]/vals[[1]] == ((29/10*10^-3)/(1735/10))}]]]]} which gives you eight solutions.


1

In principle you can create an entirely real formulation and use FindMinimum like this: exp = Abs[vals[[3]]/vals[[1]] - 1.12/173.5]^2 + Abs[vals[[2]]/vals[[1]] - 2.9*10^-3/173.5]^2 /. {\[Delta] -> dr + I di , \[Epsilon] -> er + ei I}; sol = FindMinimum[exp , {{dr, -5.7}, {di, 6.1}, {er, -1.4}, {ei, 1.2}}] {1.67033*10^-7, {dr -> ...


5

I think this code answers the question: data = RandomInteger[{0, 1}, {120, 4}]; edges = DirectedEdge @@@ Partition[data, 2, 1]; Graph[edges, VertexLabels -> "Name"] Continuation... Because of a question in a comment here is some code that shows the derivation of graphs, spanning trees of those graphs, their disjoint union, and a highlighted ...


0

If the length of your vector can always be guaranteed to be correct (exactly good for an upper triangular matrix), then the following will work. v = {a1, a2, a3, a4, a5, a6}; d = (-1 + Sqrt[1 + 8*Length[v]])/2; Array[If[#1 <= #2, v[[(2*d - #1 + 2)*(#1 - 1)/2 + #2 - #1 + 1]], 0] &, {d,d}] Please test it yourself and write it into a function if you ...


4

ClearAll["Global`*"] T = Table[0, {i, 1, 3}, {j, 1, 3}, {k, 1, 3}]; Part[Part[Part[T, 1], 1], 1] = E^(3 (KK + h)); Part[Part[Part[T, 1], 3], 3] = 3 E^(-KK + h); Part[Part[Part[T, 2], 2], 2] = E^(3 (KK - h)); Part[Part[Part[T, 2], 3], 3] = 3 E^-(KK + h); T = Normal[Symmetrize[T]]; h = 0; KK = 10; im = Partition[Flatten[TensorContract[TensorProduct[T, T], ...


3

You can't change the arguments inside the function, like you can with a subroutine in other programming languages. Make a local copy, use it, return it: multiQubitize[operator_, totalQubits_] := Module[{optmp = operator}, Do[optmp = KroneckerProduct[optmp, optmp], {i, totalQubits}]; optmp]; A cleaner way is to use Nest: multiQubitize2[operator_, ...


1

For very long lists, it may be beneficial to iterate Jens' answer. This can be achieved using NestWhile listmultiplier[list_, partitionwidth_: 5] := NestWhile[Dot @@@ Partition[#, partitionwidth, partitionwidth, 1, {}] &, list, Dimensions[#][[1]] > 1 &][[1]] This code partitions the list into sublists containing at most partitionwidth matrices, ...


1

Just another way (but not desired presentation style): grid = {{131, 673, 234, 103, 18}, {201, 96, 342, 965, 150}, {630, 803, 746, 422, 111}, {537, 699, 497, 121, 956}, {805, 732, 524, 37, 331}}; dim = Dimensions[grid]; vw = Catenate@ MapIndexed[ (#2[[2]] - 1) 5 + #2[[1]] -> #1 &, grid, {2}]; s = GridGraph[dim, VertexLabels -> "Name", ...


6

I wanted to be able to extract the path from your recursive memoized function, but I couldn't make it happen. But here is a function to find the minimum path from the upper left to the bottom right corners of an array of numbers, minimalpathsum[grid_] := Module[{dims, vertcoords, graph, weights, path, indices}, dims = Dimensions@grid; vertcoords = ...


2

With a slight modification of your MinPath function so that it takes a matrix as input ClearAll[MinPathF, nextF] MinPathF[mat_][i_, j_] := MinPathF[mat][i, j] = mat[[i, j]] + Piecewise[{{Min[MinPathF[mat][i + 1, j], MinPathF[mat][i, j + 1]], i < Length[mat] && j < Length[mat[[i]]]}, {MinPathF[mat][i + 1, j], i < ...


1

So you can't ask for more elements of the list than it has, so you can't have the iterators x and y go higher than 5 in your code. Then you can just use ArrayPad to do the padding: lis = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}}; n = 6; sum = ConstantArray[0, {5, 5}]; Do[sum[[x, y]] = lis[[Floor[x/2] + 1, Floor[y/2] + 1]] + ...


4

You simply need to simplify your result using Simplify (dimensions < 4) or FullSimplify (larger), as appropriate: Inverse@FourierMatrix[3].FourierMatrix[3] // Simplify (* Out: {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}} *) FullSimplify[Inverse@FourierMatrix[7].FourierMatrix[7]] == IdentityMatrix[7] (* Out: True *) As you can see, an identity matrix is obtained ...


2

MapThread[Map[t \[Function] {#1, t}, #2] &, {v, a}]


2

You can achieve the desired result in many ways with Mathematica. Just some variants in addition: MapThread[Thread[{##}] &, {v, a}] Inner[Thread[{#1, #2}] &, v, a, List] g[x_, y_] := Prepend[{#}, y] & /@ x; h[x_, y_] := {y, #} & /@ x; t = Thread[{a, v}]; g @@@ t h @@@ t


2

Here's a quick way to get there, Thread /@ Transpose@{v, a} (* {{{10, 1}, {10, 2}, {10, 3}}, {{11, 4}, {11, 5}, {11, 6}}, {{12, 7}, {12, 8}, {12, 9}}} *) The point here is that Transpose@{v, a} gives {{10, {1, 2, 3}}, {11, {4, 5, 6}}, {12, {7, 8, 9}}}, and you can use Thread on the individual elements.


2

There is probably a better solution, but this should work. Example: a={{1,2,3},{4,5,6},{7,8,9}} v={10,11,12} Thread[List[v[[#]], a[[#]]]] & /@ Range @ Length @ v Alternative: MapThread[Thread[{##}] &, {v, a}] Output: (*{{{10, 1}, {10, 2}, {10, 3}}, {{11, 4}, {11, 5}, {11, 6}}, {{12, 7}, {12, 8}, {12, 9}}}*)


0

I fixed the issue by utilizing the "Cubics" and "Quartics" options for eigensystem. The code runs much quicker and the manipulates are smoother. There is no more eigenvalues jumping around. Before the output of the eigensystem was a bunch of "root" expressions which I believe remained unevaluted until the plot functions. Now that the expressions are expanded ...


2

Here is the code converted to function + some corrections: function[arrays : {__?ArrayQ}] := Module[{ temp1, temp2, temp3 }, temp1 = Join @@ arrays[[{1, 2}]]; temp2 = Join @@ arrays[[{4, 5}]]; temp3 = Transpose[{ temp1[[;; , 1]], temp1[[;; , 2]] - temp2[[;; 2]] }]; {temp1, temp2, temp3} ] There is no check if appropriate ...


1

The comments provide very nice answers. Perhaps you wish the 2 x 2 analogs of 1 and I: r = IdentityMatrix[2]; i = {{0, -1}, {1, 0}}; fun[z_] := {r, i}.ReIm[z] Note i.i yields {{-1,0},{0,-1}}= -IdentityMatrix[2]. Look at the comments as they show very nice ways of achieving this.


1

Since the value you are trying to remove is "Indeterminate", you can simply set all these to zero: s1 = RandomInteger[{-3, 3}, {5, 5}]; s2 = RandomInteger[{-3, 3}, {5, 5}]; Quiet[1/2 ArcTan[s1, s2] //. Indeterminate -> 0. // N]


5

Map[0 &, mat, {3}] {{a, 0, 0}, {d, a, 0}, {0, 0, 0}} Map[0 &, #, {3}] - # &@mat {{0, 0, b}, {0, 0, 0}, {0, 0, a}}


2

mat = {{a, 0, -b}, {d, a, 0}, {0, 0, -a}}; (mat2 = PowerExpand@ComplexExpand@((# + Abs[#])/2) &@mat) // MatrixForm (mat3 = -PowerExpand@ComplexExpand@((# - Abs[#])/2) &@mat) // MatrixForm Alternatively, but perhaps not as robust, (mat2 = (# + (# /. -x_ :> x))/2 &@mat) // MatrixForm (mat3 = mat2 - mat) // MatrixForm


14

Using an undocumented function: mat /. x_?Internal`SyntacticNegativeQ :> 0 {{a, 0, 0}, {d, a, 0}, {0, 0, 0}} % - mat {{0, 0, b}, {0, 0, 0}, {0, 0, a}}


14

Simplify[MapThread[Max, {mat, 0 mat}, 2], Assumptions -> {a > 0, b > 0, d > 0}] (* {{a, 0, 0}, {d, a, 0}, {0, 0, 0}} *) Simplify[MapThread[Max, {-mat, 0 mat}, 2], Assumptions -> {a > 0, b > 0, d > 0}] (* {{0, 0, b}, {0, 0, 0}, {0, 0, a}} *)


2

The confusion is arising probably due to a misunderstanding of what PrependTo does. Note that PrependTo has attribute HoldFirst. After prepending ConstantArray[1,2] to the first part of a, the result is stored not in a, but rather as a DownValue to Subscript. The Subscript doesn't get turned into Part thanks to the HoldFirst attribute. Also, the symbol a ...


7

With the option setting Method->"Gaussian", GaussianMatrix gives the same result as your approach: GaussianMatrix[2, Method -> "Gaussian"] {{0.00296902, 0.0133062, 0.0219382, 0.0133062, 0.00296902}, {0.0133062, 0.0596343, 0.0983203, 0.0596343, 0.0133062}, {0.0219382, 0.0983203, 0.162103, 0.0983203, 0.0219382}, {0.0133062, ...


3

As noted by Rahul, one can always fall back on using the Rodrigues rotation formula if need be: rodrigues[th_, axis_?VectorQ] := With[{om = -LeviCivitaTensor[3].Normalize[axis]}, IdentityMatrix[3] + om Sin[th] + 2 MatrixPower[om, 2] Sin[th/2]^2]


2

Here is a way that works with arbitrary dimension arrays, without using a dummy counter index: SparseArray[MapIndexed[# -> a[First@#2] &, Sort[Flatten[MapIndexed[ #2 & , #, {-1}], Depth[#] - 2]]]] &@Array[0&, {2, 4, 2}] even play with SortBy to tweak the ordering: SparseArray[MapIndexed[# -> a[First@#2] &, ...


2

n = 4; lst = Table[a[i], {i, 0, n}] A = Partition[lst, n/2] // MatrixForm a[1] a[2] a[3] a[4]


1

Just something different: foo[m__] := Module[{pat = Array[_ &, {m}], list = Array[a, Times[m] ]}, ReplacePart[pat, Thread[Position[pat, Verbatim[_]] -> list]] ] Use foo[2, 2, 1] {{{a[1]}, {a[2]}}, {{a[3]}, {a[4]}}}


2

It's like the opposite of code-golf, With[ {n = 3, m = 5}, mat = ConstantArray[1, {n, m}]; i = 1; For[j = 1, j <= n, j++, For[k = 1, k <= m, k++, mat[[j, k]] = a[i]; i++; ] ]; ] mat // MatrixForm


1

One more way: ClearAll@a Block[{i = 1}, Array[a[i++] &, {3, 4}]] // MatrixForm


1

Here's another take (although I would have actually done it Szabolcs's way). mat = {{f, "x"}, {1, Sin[23]}} Module[{i = 1}, Replace[mat, _ :> a[i++], {2}]] (* {{f, "x"}, {1, Sin[23]}} *) (* {{a[1], a[2]}, {a[3], a[4]}} *)


5

matF1 = Partition[# /@ Range[#2 #3], #3] & matF2 = ArrayReshape[Array[#, Times[##2]], {##2}] & (* thanks: J.M. *) {matF1[a, 2, 3], matF2[a, 2, 3]} { {{a[1], a[2], a[3]}, {a[4], a[5], a[6]}}, {{a[1], a[2], a[3]}, {a[4], a[5], a[6]}}} matF2[a, 2, 3, 2] {{{a[1], a[2]}, {a[3], a[4]}, {a[5], a[6]}}, {{a[7], a[8]}, {a[9], ...


3

Another method, makeMat[n_, m_] := Map[a, Array[#2 &, {n, m}] + m Range[0, n - 1], {2}] makeMat[4, 5] // MatrixForm


5

With a little indexing arithmetic, one can use only Array[] to generate the required matrix: With[{m = 4, n = 4}, Array[C[n (#1 - 1) + #2] &, {m, n}]] {{C[1], C[2], C[3], C[4]}, {C[5], C[6], C[7], C[8]}, {C[9], C[10], C[11], C[12]}, {C[13], C[14], C[15], C[16]}}


15

Partition[ Array[a, 4], 2] will do it. In general, makeMat[n_, m_] := Partition[ Array[a, n*m], m]


2

I think the simplest way to handle the general case is to use TensorProduct and TensorContract, as follows: Take a rank 3 array for example, in dimension 100: In[1]:= A = RandomReal[{-1, 1}, {100, 100, 100}]; Construct a rank 12 array. Note the use of Inactive, to avoid TensorProduct constructing a large intermediate array: In[2]:= A4 = ...


2

I am illustrating my answer with a very short code. Rather, it is a long comment. The computational complexity of your two examples is cardinally different. In the first case you perform 7 matrix multiplications and perform a trace on the result. The last operation has a quadratic scaling. Therefore leading complexity is $7 N^3$, where $N$ is the matrix ...



Top 50 recent answers are included