20

ClearAll[step, bishopsPath] step[{nc_, nr_}][{start : {_, _}, {_, _}}] := {Total @ #, Last[{Total @ #, #[[2]]} /. {{t : start | {1 | nc, 1 | nr}, _} :> {t, {0, 0}}, {t : {_, nr} | {_, 1}, d_} :> {t, {1, -1} d}, {t : {1, _} | {nc, _}, d_} :> {t, {-1, 1} d}}]} &; bishopsPath[{nc_, nr_}][arg : Alternatives[{{1, _}, {-1, _}}, {{_,...


20

An example target, a bit over half-a-million digits: x = 123456!; IntegerLength@x 574965 Results for target, and a non-hit: Reduce`FactorialInverse[x] // AbsoluteTiming Reduce`FactorialInverse[x+1] {0.0138732, {123456}} {} I do not suggest trying to compare this with the function suggested in the current comment: it never finishes / crashes my kernel (12....


15

Stirling's approximation, $n! \sim n^ne^{-n}$, is the Swiss army knife of factorial problems. If $x = n!$, this implies that $\ln x \sim n \ln n - n$; and surprisingly this can be solved with a built-in special function: Solve[n (Log[n] - 1) == Log[x], n] (* {n -> Log[x]/ProductLog[Log[x]/E]} *) So we calculate this number, look at nearby integers, ...


11

Select[Subsets[s], Tr@# == t&] Should accomplish what you're after. If you'd like to allow multiset results, IntegerPartitions[t, All, s]


11

Be warned: this is a long answer, because I'm trying to be sufficiently general to treat basic graph colorings in Mathematica and maximally explanatory for anyone reading. tl;dr: Define graph colorings; create functions that identify generate colorings; then quotient the set of colorings by the graph automorphisms, by creating literal equivalence classes of ...


11

L[n_, m_] := Permutations@Array[Boole[# <= m] &, n] L[3, 2] (* {{1, 1, 0}, {1, 0, 1}, {0, 1, 1}} *)


10

I had an old program lying around that will generate all realizations of a degree sequence. The first vertex will have degree equal to the first element in the input list, the 2nd degree equal to the 2nd element, and so on. The program requires my IGraph/M package for graphicality testing. For details on how it works, see http://bolyai.cs.elte.hu/egres/tr/...


9

slist = StringJoin /@ Permutations[Characters@"ABCabc"]; pat = a_ ~~ b_ /; ToUpperCase[a] != ToUpperCase[b] && UpperCaseQ[a] != UpperCaseQ[b]; Select[StringFreeQ[pat]]@slist {"ABCcab", "ABCcba", "ABbacC", "ACBbac", "ACBbca", "ACcabB", "AabBCc", "AabcCB", &...


9

You can add the options ViewProjection, ViewPoint, and ViewVertical to make it appear as if it isometric: coversQ[parent_,child_]:=And[Length[parent]>=Length[child],Min[Take[parent,Length@child]-child]>=0] planepartitionQ[par_]:=MatchQ[par,{{___Integer}..}]&&If[Length[par]>1,And@@MapThread[coversQ,{Drop[par,-1],Rest[par]}],True] ...


8

The accepted answer will quickly blow up with arguments of more than trivial sizes. For example, with vals = {10, 20, 5, a, b, c} and n=10, it takes nearly two minutes to finish on my laptop, generating only 3003 results. Better to generate the results directly, as a simple nested iteration: f2[vals_, n_] := With[{i = {#2, #1, Length@vals} & @@@ ...


8

I'd implement backtracking like this: cylinders = {{4, 1, 1, 1, 3, 1}, {3, 1, 1, 1, 2, 1}, {1, 2, 2, 4, 1, 3}, {3, 2, 1, 2, 3, 1}}; sums = FromRomanNumeral[{"XI", "V", "X", "IV", "IX", "VI"}]; bt[rotations_] := If[ Length[rotations] == 4, If[evaluate[rotations] == sums, Throw[rotations]], If[ ...


8

With a little borrowing from JimB comment to populate all the possible solutions, another way to solve it is by using Partition[ ..., 2, 1, 1] to pick every two seat next to each other with start and ending seat case: ps = Join[{-1}, #] & /@ Permutations[{1, -2, 2, -3, 3, -4, 4}]; result = DeleteCases[ps, l_ /; AnyTrue[Partition[l, 2, 1, 1], Plus @@ # ==...


8

I will show how similar tasks can be done using (undocumented) Streaming framework. The usual caveat applies: since this is undocumented functionality, there is no guarantee that it will exist in the future versions in the same exact form, or at all. But I thought it may be a nice application to illustrate some of the ideas behind Streaming, as well as to ...


7

The function refinementQ[x, y] returns True if partition y is a refinement of partition x: ClearAll[refinementQ, oneElementRefinementQ] refinementQ[x_, y_] := And @@ (Function[i, Or @@ (SubsetQ[#, i] & /@ x)] /@ y); oneElementRefinementQ[x_, y_] := And[Length[y] == 1 + Length[x], refinementQ[x, y]] partitions4 = SortBy[{Length@# &, Min[Length /@ #]...


7

lsts = Join[Thread[{Range[8], "sing"}], Thread[{Range[6, 10], "dance"}]]; Length @ Select[ Count[Last /@ #, "sing"] == 2 && Count[Last /@ #, "dance"] == 2 && CountDistinct[First /@ #] == 4 &] @ Subsets[lsts, {4}] 199


7

singerpairs = Subsets[Range[1, 8], {2}] dancerpairs = Subsets[Range[6, 10], {2}] Count[Union @@@ Tuples[{singerpairs, dancerpairs}], {_, _, _, _}] (* 199 *)


7

You could use LinearProgramming. To use LinearProgramming, convert the list of lists into a single list. For your example we create the list {1, 2, 3, 4, 5, 6, 7, 1, 3, 2, 4, 6}. Since there is no criteria for which tuple to return, I use a cost vector of all 1s. Then, LinearProgramming will try to find a vector v whose dot product with this cost vector is ...


7

A brute-force approach is to divide the candidate by 2, then divide the result by 3 etc. until you find a number that is not an exact divisor. If your ultimate quotient is 1, then the candidate was a factorial, of the last number you divided it by. Here is an implementation of that algorithm: ClearAll[isFactorial] isFactorial[n_Integer] := Module[{result}, ...


6

The easiest way is to just work it out. First let's implement a version of L using NonComutativeMultiply: L[a_, b_] := Plus @@ Map[ Distribute[#, Plus, NonCommutativeMultiply]&, {T[a] ** b, a ** T[b], b ** T[a], T[b] ** a} ] The Distribute makes sure that all the multiplications are expanded out. By using Plus, identical terms will be grouped ...


6

I have a Mathematica package for generating Catalan objects on GitHub, so I have some recursive algorithm which generates what you want. Moreover, it has a nice graphical representation of these, and some operations on these, such as rotation. Just download the package, and do Needs["CatalanObjects`"] Last /@ NonCrossingPartitions[4] to get {{{1, ...


6

I believe this is what you're after: f=Tr[Length /@ First@FindPermutation@# - 1]&; Use: f@{2, 3, 1, 5, 6, 4, 8, 9, 7} f@{7, 1, 3, 2, 4, 5, 6} 6 5


6

VowelQ[s_String] := MatchQ[s, "a" | "e" | "i" | "o" | "u"]; Select[Permutations[StringSplit["aeeiuchklpr", ""], {6}], First[#] == "h" && VowelQ[Last@#] && Count[VowelQ /@ #, True] == 2 &] // Length 3120


6

n = 2; vals = {0, 1}; Tuples[vals, {n}] // DeleteDuplicatesBy[#, Sort] & As the comment said Tuples[vals, {n}] // DeleteDuplicatesBy[Sort] Also works, more clear. Some explanations: The key is: you "sort" the list to see whether they are duplicate. So I use Sort to be DeleteDuplicatesBy's condition.


6

The following should give you valid permutations, though I am not sure whether they are always minimal. At least for your second example I get the same number of swaps. Swaps[orig_, final_] := Rule @@@ (Sequence@@Partition[#,2,1]& /@ First@FindPermutation[final, orig]) Swaps[{a, b, c, 1, 2, 3, 4, 5}, {3, 4, 5, 1, 2, a, b, c}] {1->6,2->7,3->8}...


6

DeleteCases[{x__ /; Not@CoprimeQ[x]}]@f DeleteCases[Except[_List?(Apply[CoprimeQ])]]@f both give {{1, 2, 3}, {1, 2, 5}, {1, 3, 2}, {1, 3, 4}, {1, 3, 5}, {1, 4, 3}, {1, 4, 5}, {1, 5, 2}, {1, 5, 3}, {1, 5, 4}, {2, 1, 3}, {2, 1, 5}, {2, 3, 1}, {2, 3, 5}, {2, 5, 1}, {2, 5, 3}, {3, 1, 2}, {3, 1, 4}, {3, 1, 5}, {3, 2, 1}, {3, 2, 5}, {3, 4, 1}, {3, 4, 5}, {3, ...


6

Unfortunately, I don't have time to figure out a full answer, but here are some tips which may help. They require my IGraph/M, which you should find generally useful if you work on such problems. We can generate all such labelled trees using Prüfer sequences. The degree of a vertex is equal to the number of times it appears in the Prüfer sequence plus one. ...


6

Here are all $4$ solutions to the puzzle Technique #1 heavily plagiarizing this excellent answer Apparently Groupings is the tool for the job! ans = Groupings[ Permutations[{7, 7, 7, 7, 1}]~Join~Permutations[{7, 7, 7, 1}] , {Plus, Subtract, Times, Divide} -> 2 , HoldForm ]; Grid[ Thread[{Quiet[...


6

Here's an answer that seems pretty fast and small. It essentially just implements a simple depth-first search, with the current row of s being investigated being at index i, and the current index investigated in each row j being a[j]. It also handles your kmin case, with the default (omitted argument) being k. It stores some found values, but not many—only ...


6

With[{n = 5, k = 2}, ReplacePart[ConstantArray[0, n], Thread[# -> 1]] & /@ Subsets[Range[n], {k}]] {{1, 1, 0, 0, 0}, {1, 0, 1, 0, 0}, {1, 0, 0, 1, 0}, {1, 0, 0, 0, 1}, {0, 1, 1, 0, 0}, {0, 1, 0, 1, 0}, {0, 1, 0, 0, 1}, {0, 0, 1, 1, 0}, {0, 0, 1, 0, 1}, {0, 0, 0, 1, 1}}


6

Clear["Global`*"] factorialTest[x_Integer?Positive] := Module[{lb, nlow}, lb = MaxValue[{nlow, nlow! <= x}, nlow, Integers]; If[lb! == x, x == Inactive[Factorial][lb], Inactive[Factorial][lb] < x < Inactive[Factorial][lb + 1]]] factorialTest[6402373705728000] factorialTest[51090942171709420000]


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