Re: Find Upper Neighbor in a list
- To: mathgroup at smc.vnet.net
- Subject: [mg87012] Re: Find Upper Neighbor in a list
- From: "alexxx.magni at gmail.com" <alexxx.magni at gmail.com>
- Date: Sat, 29 Mar 2008 04:21:45 -0500 (EST)
- References: <fnhnl4$f9o$1@smc.vnet.net> <fnn11v$k2g$1@smc.vnet.net>
Hi Oleksandr, I downloaded and looked with interest at your notebook in http://tinyurl.com/3a7k65 I'd like to ask you - do you have developed code for checking if a poset is a lattice? thanks for any help... alessandro On 29 Gen, 12:01, sashap <pav... at gmail.com> wrote: > On Jan 27, 4:50 am, P_ter <peter_van_summe... at yahoo.co.uk> wrote: > > > I forgot to mention: > > {1,5,6}, {1,2,5,6}, {1,3,5,6} (all combinations of different sets containing {5,6}) are upper neighbors of {5,6] when they appear in the basis list. And through their length they can be traced easily (see the module). Because some lengths just do not appear this way of doing it could result in a more efficient solution.But again: for now it is difficult for me to formulate that in Mathematica. I need some examples. > > Thanks in advance. > > P_ter > > Dear Peter, > > If we add these instances, > > el = {{5, 6}, {1, 5, 6}, {5, 6, 8}, {1, 2, 5, 6}, {1, 3, 5, > 6}, {5, 6, 7, 8}, {1, 2, 3, 5, 6}, {1, 2, 3, 4, 5, 6, 7, 8}}; > > the upper neighbours are now {5,6,8} and {1, 5, 6}, as far as I can > say, because > > {5,6} \[Element] {1,5,6} \[Element] {1,2,5,6} and similarly for > {1,3,5,6}. > > Now, packaging the code I posted earlier: > > Poset[el_List?OrderedPosetQ] := Module[{e2, graph}, > e2 = Cases[Rule @@@ Subsets[el, {2}], > HoldPattern[x_ -> y_] /; x === Intersection[x, y]]; > graph = FixedPoint[ > Cases[#, HoldPattern[x_ -> y_] /; > Cases[el, z_ /; MemberQ[#, Rule[z, y]] && > MemberQ[#, Rule[x, z]], {1}] === {}, {1}] &, e2]; > graph > ] > > UpperNeighbours[el_List?OrderedPosetQ] := > ReplaceList[First[el],Poset[el]] > > we get: > > In[85]:= UpperNeighbours[el] > > Out[85]= {{1, 5, 6}, {5, 6, 8}} > > It is easy to generate such posets randomly for testing purposes. > > RandomPoset[ra_, {lb_, ub_}, n_] := Module[{subs, ran, ran1, el}, > subs = Subsets[Range[ra], {lb, ub}]; > While[ > Position[ ran = Sort[ > RandomSample[subs, Min[n, Length[subs]]]], {_, _}, {1}, > 1] =!= {}, > ran1 = First[ran]; > el = Cases[ran, x_ /; ran1 == Intersection[x, ran1]] > ]; el] > > This can now be used for performance comparisons. > > In[123]:= BlockRandom[RandomSeed[2008]; > Length[el = RandomPoset[15, {2, 7}, 10^3]]] > > Out[123]= 164 > > In[124]:= Timing[graph =Poset[el];] > > Out[124]= {7.656, Null} > > In[125]:= First[el] > > Out[125]= {8, 14} > > In[126]:= ReplaceList[el[[1]], graph] > > Out[126]= {{6, 8, 14}, {8, 11, 14}, {2, 3, 8, 14}, {2, 7, 8, 14}, {4, > 8, 9, 14}, {7, 8, 13, 14}, {8, 9, 12, 14}, {8, 10, 13, 14}, {8, 13, > 14, 15}, {1, 4, 8, 12, 14}, {1, 8, 12, 13, 14}, {2, 4, 8, 13, > 14}, {2, 8, 12, 14, 15}, {3, 5, 8, 14, 15}, {4, 5, 8, 13, 14}, {4, > 8, 10, 14, 15}, {5, 7, 8, 14, 15}, {1, 5, 8, 10, 14, 15}, {3, 4, 7, > 8, 12, 14}, {1, 3, 5, 7, 8, 12, 14}} > > You can try if the code works fine for your problems, or if it simply > stalls. Let me know. > > Additionally, you might find the package 'posets' by John Stembridge > of > interest ( seehttp://tinyurl.com/2q46fu). > > The notebook with the code posted, as well as additional examples can > be > found at http://tinyurl.com/3a7k65 > > Regards, > Oleksandr