# Tag Info

## Hot answers tagged combinatorica

12

The problem is that you defined the Graph using M syntax and not Combinatorica syntax. For your example you should do: g = CombinatoricaGraph[{{{1,2}},{{2,3}}}, {1,2,3}] CombinatoricaGraph[{{{1, 2}}, {{2, 3}}}, {1, 2, 3}] Then, you can use the Combinatorica functions: code = CombinatoricaLabeledTreeToCode[g] CombinatoricaCodeToLabeledTree[code] {...

12

FindShortestPath supports two methods "BellmanFord" and "Dijkstra" and it works on normal non-combinatorica Graphs.

10

You'll want to manipulate $ContextPath. The following will do: removeCombinatorica[] := ( oldContextPath =$ContextPath; $ContextPath = DeleteCases[$ContextPath, "Combinatorica"]; ) readdCombinatorica[] := ($ContextPath = oldContextPath;) Then you can call removeCombinatorica[] before whatever you want to ignore Combinatorica, and readdCombinatorica[] ... 9 GraphComputationGraphJoin GraphComputationGraphJoin[PathGraph[{a, b}], PathGraph[{c, d, e}], VertexLabels -> "Name", ImagePadding -> 10, GraphLayout -> "MultipartiteEmbedding"] This undocumented function works in both version 9.0 and version 11.3. 9 In general, if we first use GraphAutomorphismGroup to find the automorphism group of a graph, it is not hard to figure out if it acts transitively on vertices, edges, arcs, pairs of vertices at distance$k$, or any other objects. For example, to test if a graph g is arc-transitive: test if Complement[Join[EdgeList[g], Reverse /@ EdgeList[g]], ... 7 Apparently, they killed it off without making an equivalent, so you'd have to re-implement an algorithm. documentation link is here: Upgrading from: Combinatorica In some cases, parameterized variants have not yet been implemented in the Wolfram System, but a subset can be found in GraphData. ... So you'll have to make your own. This should work ... 7 The type of a permutation of length$n$is$\{\lambda_1, \lambda_2, \ldots, \lambda_n\}$where$\lambda_i$is the number of cycles of length$i$. Therefore, the number of permutations of$\{1, 2, 3, 4, 5, 6\}$that have two 1-cycles and two 2-cycles is NumberOfPermutationsByType[{2, 2, 0, 0, 0, 0}] (* 45 *) The best reference for Combinatorica is Steven ... 7 The function you reference still works fine, but it is part of the Combinatorica package. You need to load the package first, and work with Combinatorica's own graph datatype. Combinatorica precedes Mathematica's built-in graph datatype by many years, and is not interoperable with it. That said, it is relatively easy to implement an equivalent function for ... 7 IGraph/M 0.3.111 now has fast functions to test for all of these. Please look under Isomorphism -> Properties related to the automorphism group in the documentation. Regular: IGRegularQ Vertex transitive: IGVertexTransitiveQ. Edge transitive: IGEdgeTransitiveQ. Strongly regular: IGStronglyRegularQ. Distance regular: IGDistanceRegularQ. Distance transitive: ... 7 The IGraph/M package has an implementation of this. Example: << IGraphM g = RandomGraph[{10, 20}] Compute the chromatic number: IGChromaticNumber[g] (* 4 *) Compute a minimum colouring: IGMinimumVertexColoring[g] (* {3, 1, 4, 2, 2, 4, 1, 3, 1, 2} *) Visualize it: IGVertexMap[ColorData[97], VertexStyle -> IGMinimumVertexColoring, Graph[... 6 Assuming there is a Method other than "AllTours" that doesn't break if one point doesn't obey the triangle inequality, introduce a special point that has a distance 0 to all other points: points = {{-0.9, -0.89}, {.99, .97}, {0.1, .0}, magicPoint}; d[args__] /; FreeQ[{args}, magicPoint] := EuclideanDistance[args] d[__] = 0; FindShortestTour[points, ... 6 You can find the code for the function in the file Combinatorica.m: nb = NotebookOpen[ToFileName[{$InstallationDirectory, "AddOns", "Packages", "Combinatorica"}, "Combinatorica.m"]]; NotebookFind[nb, "ListGraphs[n_Integer?Positive, m_Integer]"]

5

It is hard to explain your DualPartition code as it does not seem to work on the Young tableaux generated by the Combinatorica package. Let's try to write something ourselves. Assuming DualPartitioncalculates a conjugate tableau this could be written as follows: Needs["Combinatorica"] The Tableau function generates Young tableaux: Tableaux[5] (* {{{1, 2,...

5

The presently Accepted solution is quite slow, at least on long lists. We can improve performance of this brute-force algorithm by orders of magnitude using numeric vector operations. Consider: f1[a_] /; VectorQ[a, IntegerQ] := Sum[Tr @ Clip[a[[i]] ~Subtract~ Drop[a, i], {0, 1}], {i, Length@a}] f1[a_List] := f1 @ Ordering @ a Compared to myinversions ...

5

I hope the following is helpful: Firstly, consider this example: gr = SystemGraph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 3 <-> 5}]; sysm = SystemAdjacencyMatrix[gr]; com = CombinatoricaFromAdjacencyMatrix[Normal@sysm]; aut = CombinatoricaAutomorphisms[com]; ex = SystemGraph[EdgeList[gr], VertexLabels -> Table[j -> Placed[#[[j]],...

5

FromAdjacencyMatrix construct combinatorica graph. Subgraph and HighglightGraph accept system graph object. Instead of loading Combinatorica package, you can just create graph from matrix by using AdjacencyGraph: gr = AdjacencyGraph[BB] Then Subgraph should work fine with it: Subgraph[gr, {1, 2}]

5

For those who are facing a similar problem, there is a beautiful package xTras which gives all possible contractions taking into account the symmetries of the tensors. The command is AllContractions; have a look here arxiv.org/1308.3493

5

Although xTras package is everything you need, I made a function (just for fun) that finds all the contraction of the product of 2-ranked tensors. It uses sort of bruteforce combinatorics, so it will be deadly slow on a large number of tensors. However, 3-5 tensors work just fine. NiceTensor[ilst_,names_]:=Inner[Subscript[#2,#1]&, StringJoin[ToString/@#]...

4

There are short description and the definition of the Tableaux: Quiet@Needs["Combinatorica"]; ?? Tableaux Tableaux[p] constructs all tableaux having a shape given by integer partition p. Attributes[Tableaux] = {Protected} Tableaux[s_List] := Module[{t = LastLexicographicTableau[s]}, Table[t = NextTableau[t], {NumberOfTableaux[s]}]] Tableaux[...

4

Something like this? myinversions[list_] := Select[ Subsets[Range[Length[list]], {2}] , list[[#[[1]]]] > list[[#[[2]]]] & ] // Length Verify the same result as builtin Inversions for a permutation Needs["Combinatorica"] And @@ (Inversions[#] == myinversions[#] & /@ Permutations[Range[5]]) True myinversions[{1, 4, 2, 5, 2,...

4

You can use CycleIndexPolynomial like so: CycleIndexPolynomial[ GraphAutomorphismGroup@GridGraph[{3, 3}], Array[Subscript[s, #] &, 4] ] $$\frac{s_1^9}{8}+\frac{1}{2} s_2^3 s_1^3+\frac{1}{8} s_2^4 s_1+\frac{1}{4} s_4^2 s_1$$

4

InternalPartitionRagged[{a, b, c, d, e}, #] & /@ Flatten[Permutations /@ IntegerPartitions[5], 1] About InternalPartitionRagged: I have read about it here.

4

The function FindProperColorings is now in the Wolfram Function Repository, and it lists all the proper k-colorings of a graph. https://resources.wolframcloud.com/FunctionRepository/resources/FindProperColorings

4

Please see Computational Discrete Mathematics by Pemmaraju and Skiena, pages 106 and 107. DerangementQ[p_?PermutationListQ]:= !(Apply[Or,Map[(#===p[[#]])&,Range[Length[p]]]]) NumberOfDerangements[0] = 1; NumberOfDerangements[n_Integer?Positive] := Block[{$RecursionLimit = Infinity}, n*NumberOfDerangements[n - 1] + (-1)^n] Derangements[0] = {{}}; ... 3 Option 1 f[list_] := With[{part = Flatten[Permutations /@ IntegerPartitions[Length[list]], 1]}, Table[ First@Last@ Reap[FoldList[(Sow[First[#]]; Last[#]) &@*TakeDrop, list, p]] , {p, part}] ] f[{a, b, c, d, e}] // MatrixForm Option 2 PartitionRagged[vec_, lens_] := MapThread[vec[[#1 ;; #2]] &, With[{a = Accumulate[... 3 Possible partitions for a list with 5 elements: n = 5; Union@Select[Tuples[#, Length@#], Total@# == n &] & /@ IntegerPartitions[n] // Sort // MatrixForm 3 You can try adding the context of the functions explicitly if you're having clashes with Combinatorica, e.g. SystemPermutationReplace[] and SystemPermutationCycles[]: SystemPermutationReplace[{2, 3, 4}, SystemPermutationCycles[{2, 1, 3, 5, 4}]] Another possibility is suggested in Leonid's answer here: Block[{$ContextPath}, Needs["Combinatorica`"]]; ...

3

Here's a generic answer: YD[n_, d_] := Cases[Tuples[ Flatten[{Flatten[{Table[IntegerPartitions[i], {i, n, 1, -1}], 0}, 1], IntegerPartitions[n]}, 2] /. Table[{i} -> i, {i, n}] // DeleteDuplicates, d], a_ /; TrueQ[Total[Flatten[a]] == n]] // DeleteDuplicates Here n is how high the numbers go, and d the amount of tuples. The ...

3

Update: Still 4X slower than @Mr.W' method, but much faster than ones in the original post is invF5 = With[{ss = Subtract @@ Transpose[Subsets[#, {2}]]}, Total@UnitStep[ss]] & invF = Total@(1 - UnitStep[Order @@@ Subsets[#, {2}]]) & or invF2 = Count[Subsets[#, {2}], _?(Greater @@ # &)] &; or, variations on george2079's approach invF3 = ...

3

You can get the result using the builtin CycleIndexPolynomial. For example, imagine you are interested in the group CyclicGroup[5]. In[1]:= poly = CycleIndexPolynomial[CyclicGroup[5], {a[1], a[2], a[3], a[4], a[5]}] Out[1]= a[1]^5/5 + (4 a[5])/5 Suppose you have three types of beads (r, g, b): In[2]:= poly /. a[i_] -> r^i + g^i + b^i // Expand Out[2]= ...

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