Lets say i have two lists with me as given below:

l1 = {4, 6, 8, 9, 10, 12};

l2 = {2, 3, 4, 5, 6, 7};

Now i have a function S2P(details irrelevant) which takes one argument and spits out a list.

S2P[a_] := DeleteDuplicates[Apply[Times,Partition[Flatten[IntegerPartitions[a, {2}]], 2], {1}]]

Now i want to feed S2P the elements of l2 and find which elements of l2 gives an output that is a subset of l1.

For e.g

S2P[5]

(*{4, 6}*)

S2P[7]

(*{6, 10, 12}*)

These are the only two elements of l2 for which the output from S2P is a subset of l1 and im finding them like this:

t1[n_] := Module[{l3, res, len},

l3 = S2P[l2[[n]]];

len = Length[l3];

res = Count[

Flatten[Table[{l3[[i]]} == {l1[[#]]} & /@ Range[Length[l1]], {i,1,len}]],True];

If[res == len, Sow[l2[[n]]]]];

DeleteCases[t1[#] & /@ Range[Length[l2]], Null]

(*{5, 7}*)

Can someone show me how to do this more efficiently for large data. Below i have shown the actual function l1 and l2 where n can go upto 1000.

f4 = #~Extract~SparseArray[Unitize[#2 – 1]][“NonzeroPositions”] & @@

Transpose@Tally@# &; (* to keep only duplicates*)

l1[n_] :=

DeleteCases[f4[Flatten[Table[i*j, {i, 1, n}, {j, 1, n}]]], _?PrimeQ]

l2[n_] :=

DeleteDuplicates[Flatten[Table[i + j, {i, 1, n}, {j, 1, n}]]]

=================

Please define “large data” — how long is l1 specifically? Also, are these lists of fairly small integers as in the example?

– Mr.Wizard♦

Jul 29 ’14 at 11:38

@Mr.Wizard I have included the working set

– Hubble07

Jul 29 ’14 at 11:54

Thanks. My method will not work for those; as it see it is important to include such things.

– Mr.Wizard♦

Jul 29 ’14 at 11:59

I suspect that this problem is quite hard. Can you tell me more about the real S2P? It may be important to restrict the search domain as much as possible.

– Mr.Wizard♦

Jul 29 ’14 at 12:02

@Mr.Wizard If i give you a positive integer n and tell you that n is a sum of two positive integer(a and b) then you are asked to give all possible products of a and b. S2P does this for any n

– Hubble07

Jul 29 ’14 at 12:21

=================

4 Answers

4

=================

With l1[n] and l2[n] defined as above,

Table[Cases[l2[n], q_Integer /; And @@ (MemberQ[l1[n], #] & /@ S2P[q])], {n, 64}]

takes 58 seconds and produces for n=64:

{5,7,9,10,11,13,15,16,17,19,21,23,25,27,28,29,31,33,35,36,37,39,40,41,43,45,47,49,51,52,53,

55,56,57,59,61,63,64,65,67}

Simplified you could use: (this simpler l1 is sorted unlike the original)

l1[n_] := DeleteCases[Union @@ Table[i*j, {i, 1, n}, {j, i + 1, n}], _?PrimeQ]

l2[n_] := Range[2, 2 n]

S2P[a_] := DeleteDuplicates[Times @@@ IntegerPartitions[a, {2}]]

V10 introduces SubsetQ

func[n_] := With[{u = l1[n]}, Select[l2[n], SubsetQ[u, S2P[#]] &]]

I use l1, l2, and S2P as defined by @Coolwater (you don’t really have to Flatten and then Partition again when the original output of IntegerPartitions is already partitioned). I define my function twice to make it take 2 lists as arguments as well as any n as defined by l1[n], and l2[n].

seismaticaQ[lis1_List, lis2_List] :=

Pick[lis2, Complement[S2P[#], lis1] & /@ lis2, {}];

seismaticaQ[n_Integer] :=

Pick[l2[n], Complement[S2P[#], l1[n]] & /@ l2[n], {}];

seismaticaQ[{4, 6, 8, 9, 10, 12}, {2, 3, 4, 5, 6, 7}]

(* {5, 7} *)

seismaticaQ[64]

(* {5, 7, 9, 10, 11, 13, 15, 16, 17, 19, 21, 23, 25, 27, 28, 29, 31, 33, \

35, 36, 37, 39, 40, 41, 43, 45, 47, 49, 51, 52, 53, 55, 56, 57, 59, \

61, 63, 64, 65, 67} *)

Comparison with @Wouter’s method (using MemberQ) and @Coolwater’s method (using MMA 10’s SubsetQ)

Clear[wouterQ, coolwaterQ]

wouterQ[n_Integer] :=

Cases[l2[n], q_Integer /; And @@ (MemberQ[l1[n], #] & /@ S2P[q])];

coolwaterQ[n_Integer] :=

With[{u = l1[n]}, Select[l2[n], SubsetQ[u, S2P[#]] &]];

ListLinePlot[

Table[{n, First[#[n] // AbsoluteTiming]}, {n, 1,

30}] & /@ {seismaticaQ, wouterQ, coolwaterQ},

PlotLegends -> {“seismaticaQ”, “wouterQ”, “coolwaterQ”},

PlotRange -> Full, AxesLabel -> {“n”, “AbsoluteTiming”}]

I await more detail regarding your working set, but if l1 is not too long you might use this:

dsp = Dispatch @ Thread[Rest @ Subsets @ l1 -> True];

Pick[l2, S2P /@ l2 /. dsp]

{5, 7}

The same thing using Associations (v10):

asc = <|Thread[Rest @ Subsets @ l1 -> True]|>;

Pick[l2, Lookup[asc, S2P /@ l2, False]]