MakeLevel[{},_,_,rank_] := rank
MakeLevel[l_List,lvl_,adjm_List,r_List] :=
  Module[ {rank=r, v, lst=l },
          rank = SetLevel[lst,lvl,rank];  (* make this level ready *)
          While[ lst != {},
                 v = First[lst];
                 rank = MakeLevel[adjm[[v]], lvl+1,adjm,rank];
                 lst = Rest[lst];
          ];
          rank
  ]

HasseDiagram[g_Combinatorica`Graph, fak_:1] :=
	Module[{r, rank, m, stages, freq=Table[0,{V[g]}],
                adjm, first, i},
	       r = TransitiveReduction[RemoveSelfLoops[g]];
               adjm = ToAdjacencyLists[r];
               rank = Table[ 0,{ V[g]} ];
               first = Select[ Range[ V[g]], InDegree[r,#]==0& ];
               rank = MakeLevel[ first, 1, adjm, rank];
               first = Max[rank];
               stages = Distribution[ rank ];
               MakeUndirected[
                   ChangeVertices[r,
		          Table[
                            m = ++ freq[[ rank[[i]] ]];
                            {((m-1) + (1-stages[[rank[[i]] ]])/2)*
                            fak^(first-rank[[i]]), rank[[i]]}//N,
                            {i, V[g]}
                          ]
                   ]
               ]
        ] /; AcyclicQ[RemoveSelfLoops[g]] && !UndirectedQ[g]