# Need an efficient way to do this list manipulation

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? Commented Jul 29, 2014 at 11:38
• @Mr.Wizard I have included the working set Commented Jul 29, 2014 at 11:54
• Thanks. My method will not work for those; as it see it is important to include such things. Commented Jul 29, 2014 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. Commented Jul 29, 2014 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 Commented Jul 29, 2014 at 12:21

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]]