Tag Info

Hot answers tagged

29

Solution minimal[sets_] := Module[{f}, f[x__] := (f[x, ___] = Sequence[]; {x}); SetAttributes[f, Orderless]; f @@@ Sort @ sets ] If the original order in the subsets must be retained one may introduce an auxiliary symbol without loss of performance: minimal2[sets_] := Module[{f, g}, f[x__] := (f[x, ___] = True; False); g[a_] /; ...


21

Metropolis algorithm Update: ~15x speedup with Compile! I propose an original solution, which consists in using the Metropolis algorithm. It is a very general approach, which is applicable for any probability density function in any dimensions. Metropolis /: Random`DistributionVector[ Metropolis[pdf_, u0_, s_: 1, n0_: 100, chains_: 200], n_Integer, ...


17

lst={a,b,c,d}; ReplaceList[lst,{x__, ___} :> {x}] Speaking of "common operation": Table[lst[[;; i]], {i, Length@lst}]


17

Lets call your plot res. res = RegionPlot[And @@ Table[ Dot[{Phi1, Phi2}, Eta[b]] <= Norm[NI[Pi] - Eta[b]]^2 + 2, {b, 0, 2 Pi, 2 Pi/10}], {Phi1, -7, 7}, {Phi2, -7, 7}]; Lets extract the mesh Mathematica is generating by default. Use more PlotPoints to get more triangular mesh of your 2D region. pts = res[[1, 1]]; (* Vertices *) {triangles, qd} = ...


15

Hybrid Mathematica - Java solution Since the top-level solution from EDIT is still rather slow, here is a Java port of it. To use it, you have to first load the Java reloader into your session. Code Having done that, we have to compile this class: JCompileLoad@"import java.util.*; public class MinSubsets{ public static Object[] ...


15

You could do something like minSubsets[lst_] := DeleteDuplicates[SortBy[lst, Length], Intersection[#1, #2] === Sort[#1] &] Then for the example in the question you get lst = {{a, b}, {b, c}, {a, b, c}, {a, b, e}, {a, c, e}, {a, e, d, f}}; minSubsets[lst] (* out: {{a, b}, {b, c}, {a, c, e}, {a, e, d, f}} *)


13

You can use ReplaceList with a helper function which has the Orderless attribute: ClearAll[f]; SetAttributes[f, Orderless]; ReplaceList[f[a, b, c], f[a___, b___, c___] :> {{a}, {b}, {c}}] // DeleteCases[#, {}, -1] & // Union // Column The DeleteCases and Union are required because the output from ReplaceList includes the empty list {} as a ...


13

There is an undocumented function LongestAscendingSequence LongestAscendingSequence[list] {1, 3, 4, 6} This was mentioned here and here in comments. I hope it will not be treated as a duplicate. I think Q&A-style on SE is more appropriate for this question. For completeness I ask the second question. It seem to be much simpler but I can't find ...


12

A variant using Take. list~Take~# & /@ Range@Length@list {{a}, {a, b}, {a, b, c}, {a, b, c, d}} One using NestList: NestList[Most, list, Length@list - 1] {{a, b, c, d}, {a, b, c}, {a, b}, {a}}


12

Subsets takes an optional 3rd argument as Subsets[list, {n}, k] that gives you the kth sublist of length n. Since your sublists are in sequence, you'll always need k = 1. You can then use this as: MapIndexed[First@Subsets[list, #2, 1] &, list] (* {{a}, {a, b}, {a, b, c}, {a, b, c, d}} *) Another alternative would be: Reverse@Most@NestWhileList[Most, ...


12

I'll show a method based on an algorithm by Bentley, Clarkson, and Levine. --- edit --- Their idea is to presort so that any obviously minimal elements are at the front. In this case, minimal length suffices for the test of being "obviously minimal". Then loop over remaining elements. For each one: Loop from beginning until we hit elements of same ...


10

Perhaps the following SetAttributes[set, Orderless]; set[elms___] := With[{nodups = DeleteDuplicates@{elms}}, set @@ nodups /; {elms} =!= nodups] So set[a, b, c, d] would represent a set with elements a, b, c, and d. To compare, just use == or ===. It automatically sorts and removes duplicates s1 = set[a, b, c, d]; s2 = set["o", b, a, aa, dd]; s1 ...


10

Ad. I These should be the most efficient and tersest Ceiling[ Range @ 27 / 3 ] or Array[ Ceiling[#/3] &, 27] yield {1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 7, 7, 7, 8, 8, 8, 9, 9, 9} they both can be tersely written in the Front End (see details of Ceiling) as: or Ad.II For the second problem there are many approaches, ...


10

Being this the first answer at the site using the Region context, I think it deserves an entry on its own: AppendTo[$ContextPath, "Region`"] z = 0; RegionPlot[ RegionProperty[ TransformedRegion[ ParametricRegion[{{p1, p2, p4}, 0 < p1 < 1 && ...


9

There are two built-in functions to generate pairs, either with (Tuples) or without (Subsets) duplication. Since your question states the number of iterations as $n*(n-1)/2$ I believe you want the latter: set = {1, 2, 3, 4}; Subsets[set, {2}] {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}} The short notation for Apply at level 1 is @@@, so this ...


9

Try the following. Note I assumed from OP that elements are non-zero integers. This could of course be adapted to other cases with appropriate mapping. getmasks[listarg_] := Reverse[Transpose[ IntegerDigits[Fold[BitSet[#1, #2] &, 0, #] & /@ listarg, 2, Max[listarg] + 1]]][[Min[listarg] + 1 ;; Max[listarg] + 1]]; ...


8

I would use: data = {1, 20, 3, 40}; Join @@ Permutations /@ IntegerPartitions[Length@data]; results = Internal`PartitionRagged[data, #] & /@ % {{4}, {3, 1}, {1, 3}, {2, 2}, {2, 1, 1}, {1, 2, 1}, {1, 1, 2}, {1, 1, 1, 1}} {{{1, 20, 3, 40}}, {{1, 20, 3}, {40}}, {{1}, {20, 3, 40}}, {{1, 20}, {3, 40}}, {{1, 20}, {3}, {40}}, {{1}, {20, 3}, {40}}, ...


8

I am not sure this wins any speed contests, but it is a purely functional solution: FoldList[#1~Join~{#2} &, {First@#}, Rest@#]& @ {a, b, c, d, e} (* {{a}, {a, b}, {a, b, c}, {a, b, c, d}, {a, b, c, d, e}} *)


8

I enjoy the solution of PlatoManiac and I want to improve it Eta[a_] := {Cos[a], Sin[a]} NI[a_] := {Cos[a], Sin[a]} res = RegionPlot[ And @@ Table[ Dot[{Phi1, Phi2}, Eta[b]] <= Norm[NI[Pi] - Eta[b]]^2 + 2, {b, 0, 2 Pi, 2 Pi/10}], {Phi1, -7, 7}, {Phi2, -7, 7}]; points = res[[1, 1]]; {id3, id4} = Cases[res[[1]], Polygon[{a___}] -> {a}, ...


8

If I'm not mistaken you can do this: (I will replace [EmptySet] with ES because I have troubles formatting it here) a = { ES, {ES}, {{ES}, ES}}; b = {#, {#, #2}} & @@@ Tuples[a, {2}]; % // Column {ES, {ES, ES}} {ES, {ES, {ES}}} {ES, {ES, {{ES}, ES}}} {{ES}, {{ES}, ES}} {{ES}, {{ES}, {ES}}} {{ES}, {{ES}, {{ES}, ES}}} {{{ES}, ES}, {{{ES}, ES}, ES}} ...


8

I don't pretend this is the most efficient or pretty, but here's a go at what I think you're after (see latter part of post for faster and simpler realizations): a = {1, 1, 2, 1, 1, 3}; b = {1, 5, 5, 1}; result = Join[ Flatten[ConstantArray @@@ Flatten[Replace[Cases[GatherBy[Join[Tally[#1], Tally[#2]], First], {{Alternatives @@ a, ...


7

A main idea of a pattern-based solution I don't know why we should make life so complicated, since you can always use things like Intersection and Complement to test whether a given set is a subset of another set. But if you want to use the pattern-matcher, here is one option: ClearAll[set]; SetAttributes[set, {Orderless, Flat, OneIdentity}]; ...


7

In a strict meaning the answer is no. A mathematical concept of a set is so basic and general, that one even cannot imagine most of sets and the more it concerns the possibility of their computer representations. For some hints of surprising properties of infinite sets see e.g. Continuum Hypothesis or Gödel's theorem. If you relate your question to finite ...


7

A brute force solution is to check all possible values of this function. num = {1/10, 1/2, 4/7, 3/5, 2/3}; pow = {0, 1, 2, 3, 4}; To obtain value for one combination use the Inner function Inner[Power, num, pow, Plus] (* => 2222701/992250 *) Then we apply function Inner[Power, num, #, Plus]& on all permutations prm = Permutations[pow]; val = ...


6

vertices = Range[10]; pairs = Tuples[vertices, 2]; func[x__] := First@x <= Last@x; edges = Pick[pairs, func[#] & /@ pairs]; (* or *) edges = Pick[pairs, Boole[func[#]] & /@ pairs, 1]; Graph[DirectedEdge @@@ edges, VertexLabels -> "Name", ImagePadding -> 20] Graph[DirectedEdge @@@ edges, VertexLabels -> "Name", ImagePadding -> 20] ...


6

Here's my version. Clear[multiComplement]; multiComplement[a_, b_] := Join @@ (ConstantArray[First@#, Max[Last@#, 0]] & /@ (Tally[a] /. (Tally[b] /. {e_, c_Integer} :> {e, k_Integer} -> {e, k - c}))); In action: With[{a = {1, 1, 2, 1, 1, 3}, b = {1, 5, 5, 1}}, multiComplement[a, b]~Join~multiComplement[b, a] ] {1, 1, 2, 3, 5, 5} ...


5

You might generate all subsets by placing special markers (asterisks) where a list should be split. data = {1, 20, 3, 40}; (* The asterisks "*" indicate where a list should be split *) data1 = Insert[data, "*", #] & /@ (Subsets[Range[2, Length[data]]] /. a_Integer :> {a}) (* out *) {{1, 20, 3, 40}, {1, "*", 20, 3, 40}, {1, 20, "*", 3, 40}, {1, ...


5

Yes, there are definitely shorter, non-loop ways to do this. Define your link-defining function like this (with whatever test you need as the first argument to If: islinked[a_Integer?Positive, b_Integer?Positive] := If[Mod[a, 3] == 0 && Mod[b, 2] == 1, a -> b, {}] You can then Apply this at the level of each row using the @@@ shorthand. I ...


5

check[l_] := If[ ++$pos; Length@$minimals === Total @ Unitize[BitNot[l] ~BitAnd~ $minimals], $minimalIndicator += 2^$pos; AppendTo[$minimals, l] ] binary[data2_, alphabet_] := Total[2^(Length@alphabet - #), {2}] &[ data2 /. Dispatch@MapIndexed[# -> #2[[1]] &, alphabet] ] minimalR[data_] := Block[{$minimals = {}, $pos = -1, ...


5

This is just to give set the proper attributes and make it simplify double ___ and __ ClearAll[set]; set[a___, Verbatim[___], Verbatim[___] .., b___] := set[a, ___, b]; set[a___, Verbatim[__], Verbatim[__] .., Verbatim[___] ..., b___] := set[a, __, b]; SetAttributes[set, {Orderless, Flat, OneIdentity}]; The patterns will be a boolean function of ...



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