Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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}]]]
share|improve this question
    
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 at 11:38
    
@Mr.Wizard I have included the working set –  Hubble07 Jul 29 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 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 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 at 12:21

4 Answers 4

up vote 1 down vote accepted

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} 
share|improve this answer

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[#]] &]]
share|improve this answer

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

Mathematica graphics

share|improve this answer

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]]
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.