5. Defining a Poset by its Covering Function 

In this section we illustrate the process by which a "new" poset can be 
constructed from a  formal description (in Mathematica) of its covering 
function.

  CHIP-FIRING POSETS

Consider this example: a pile of N stones is placed at the origin of a 
1-dimensional grid, indexed by the integers.   Subsequent moves consist of 
taking two stones located at position k, and distributing them one each to 
positions k-1 and k+1.   The possible configurations of stones frm a poset, in 
which coverings correspond to allowable moves. This poset has been studied by 
A. Bjorner, L. Lovasz, and P. Shor in a paper called "Chip-firing games on 
graphs" . 

States of the game are represented by strings of length N+1, with the initial 
state represented by a string with N in position Floor[N/2+1], and zeros 
elsewhere. For example, if N=5, the initial state is {0,0,5,0,0,0}.

The first step is to write a Mathematica program to generate, from a given 
state, a list of those states obtainable from it by an allowable move.

fire[state_] := Block[{coverlist={},i,new},
  Do[If[state[[i]]>1,
     new = state;
     new[[i-1]]++;new[[i+1]]++;new[[i]]--;new[[i]]--;
     AppendTo[coverlist,new]],
    {i,2,Length[state]-1}];   
  Return[coverlist]      
  ]

Next we define the initial state.  

initialstate[N_] := Table[If[i==Floor[N/2+1],N,0],{i,N+1}]

Finally, the poset "definition" is a triple consisting of (1) the name of the 
covering function, (2) a list of all starting states (in this case only one), 
and (3) a number which is sure to be larger than the length of the longest 
chain generated. In this case we choose N^3, though in general it's not always 
clear in advance what this bound should be.

chipfire[N_]:= {fire,{initialstate[N]},N^3} ;

Now the poset can be "built".

Build[chipfire[5],chip5]

Building poset chip5  ...
Done

P[chip5]                         

{{0, 0, 5, 0, 0, 0}, {0, 1, 3, 1, 0, 0}, {0, 2, 1, 2, 0, 0}, 
 
  {1, 0, 2, 2, 0, 0}, {0, 2, 2, 0, 1, 0}, {1, 1, 0, 3, 0, 0}, 
 
  {1, 0, 3, 0, 1, 0}, {0, 3, 0, 1, 1, 0}, {1, 1, 1, 1, 1, 0}}

Relabel[chip5,Compact]                
Diagram[chip5,ShowLabels->True]



-Graphics-

Build[chipfire[7],chip7]
Diagram[chip7]

Building poset chip7  ...
Done



-Graphics-

Build[chipfire[8],chip8]
Diagram[chip8,Thinness->.6]

Building poset chip8  ...
Done



-Graphics-

  FIBONACCI LATTICES

The r-Fibonacci lattice,  denoted by Fib(r), is defined as follows. Let A(r) = 
{0,1,...,r}, and let A(r)* denote the set of all finite words formed from 
letters in A(r).  Define Fib(r) by taking A(r)* as the underlying set, and 
letting v cover u if u can be obtained from v by changing a 0 in v to an x­0 
or by removing the last digit in v if it is non-zero. It is clear that Fib(r) 
is a graded poset with a unique minimal element. Furthermore, when r = 1, the 
number of elements at rank n is the Fibonacci number Fn+1 (where F1= F2=1, 
Fn+1=Fn + FnÐ1).

The first step is to define the covering function for Fib(r). Here 
fiblattice[r,h] returns a triple {fibcover, {{}}, h}, where fibcover is the 
covering function (depending on r), {} is the unique minimal element (the 
empty word), and h is the the rank up to which we wish to build Fib(r). Thus, 
applying Build to fiblattice[r,h] yields Fib(r) "up to" rank h.


fiblattice[r_,h_]:=Block[{},
 fibcover[w_]:= Block[{coverlist={},len=Length[w]},
   Do[AppendTo[coverlist,Flatten[{w,i}]],{i,r}];
   Do[If[!(w[[i]]==0),AppendTo[coverlist,
    Join[Take[w,i-1],{0},Take[w,-(len-i)]]]],{i,len}];
  coverlist
  ];
 Return[{fibcover,{{}},h}];
 ];



Build[fiblattice[1,5],fib105]
Relabel[fib105,Compact];
Diagram[fib105,ShowLabels->True]

Building poset fib105  ...
Done



-Graphics-

NK[fib105]

{1, 1, 2, 3, 5, 8}

The poset we have constructed is obviously not a lattice, because we have 
constructed only finitely many ranks.  However, the principal order ideals in 
Fib[r] are lattices. In fact when r=1 they are distributive lattices.

indices = IntervalP[fib105,"","100"]
Build[SubPoset[fib105,indices],ideal105]
RestoreSubPosetLabels[fib105,indices,ideal105]
Diagram[ideal105,ShowLabels->True]

{1, 2, 3, 5, 7, 10, 11, 20}

Building poset ideal105  ...
Done



-Graphics-

DistributiveLatticeQ[ideal105]

The poset is strongly ranked.

True

Next we construct Fib[2].

Build[fiblattice[2,3],fib203]
Relabel[fib203,Compact]
Diagram[fib203,ShowLabels->True]

Building poset fib203  ...
Done



-Graphics-

Build[fiblattice[2,5],fib205]
Diagram[fib205,Thinness->.4]

Building poset fib205  ...
Done



-Graphics-

RGF[fib205]

             2       3       4       5
1 + 2 q + 5 q  + 12 q  + 29 q  + 70 q

MaximalChainsDown[fib205]

{1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 4, 2, 1, 1, 4, 1, 1, 2, 1, 1, 1, 1, 6, 
 
  4, 2, 1, 1, 6, 4, 12, 1, 1, 6, 2, 1, 1, 6, 1, 1, 4, 2, 1, 1, 4, 1, 
 
  1, 2, 1, 1, 1, 1, 8, 6, 4, 2, 1, 1, 8, 6, 4, 32, 16, 12, 1, 1, 8, 
 
  6, 2, 1, 1, 8, 6, 32, 1, 1, 8, 4, 2, 1, 1, 8, 4, 16, 1, 1, 8, 2, 1, 
 
  1, 8, 1, 1, 6, 4, 2, 1, 1, 6, 4, 12, 1, 1, 6, 2, 1, 1, 6, 1, 1, 4, 
 
  2, 1, 1, 4, 1, 1, 2, 1, 1}

Exercise: what is a formula for the number of maximal chains down from each 
element of Fib[2]?

indices = IntervalP[fib205,{},{2,0,0}]
Build[SubPoset[fib205,indices],ideal205]
RestoreSubPosetLabels[fib205,indices,ideal205]
Relabel[ideal205,Compact]
Diagram[ideal205,ShowLabels->True]

{1, 3, 7, 8, 16, 17, 18, 19, 20, 40, 41, 44, 47, 100}

Building poset ideal205  ...
Done



-Graphics-

LatticeQ[ideal205]
DistributiveLatticeQ[ideal205]

True

False

So for r > 1 the Fibonacci lattice F[r] is not distributive.