(* Inverse Extensions and Isomorphism Functions *)


(* BasInvExts[] --------------------------------------------------------- *)

(* Gives all inverse order extensions of givpst. *) 

(* Utils Needed: PllOff[], CmprssBiList[]. *)	

BasInvExts[givpst_] := Module[{labform,pairlst},

	(* Label each child list with the name of its element. *)
	labform = Map[ {givpst[[#]],#}&, Range[Length[givpst]] ];

	(* Initialize big list of 
	{list of partial black pull-off sequences, remaining blue filter}'s. *)
	pairlst = {{ {{}}, labform }};

	Do[                 (* Iteratively pull off all but one black element. *)
		
		pairlst = Flatten[
                    (* Replace each pair with a list of descendant pairs. *)
			Map[Function[x,
                       (* Each min elt gives rise to one descendant pair. *)
				Map[Function[y,   
                     (* Add this min elt to each black pull-off sequence. *)
					{Map[ Append[#,y]&, x[[1]] ],
						PllOff[x[[2]], {y}] (* Remove min elt from blue filter. *)
					}],                                   (* End of Function[y *) 
                    (* List of minimal elements in remaining blue filter. *)
					Map[ #[[2]]&, Select[x[[2]],#[[1]]\[Equal]{}&] ]
				]    

			],pairlst]                              (* End of Map[Function[x *)

		,1];      (* Flatten merges all the results from various old pairs. *)
		
		(* Every other time collect pairs with same remaining blue filter. *)
		If[ (yel>3 && Mod[yel,2]\[Equal]0) \[Or] Length[pairlst] > 79,
			pairlst = CmprssBiList[ pairlst, 2, Flatten[#,1]& ]  
		]
	
	,{yel,Length[givpst]-1}];  (* End of Do loop. *)

	(* Append last blue element to ends of pull-off sequences. *)
	Flatten[
		Map[Function[x,
			Map[ Append[#,x[[2,1,2]]]&, x[[1]] ]
		],pairlst]
	,1]
];


(* InvExtsWRI[] --------------------------------------------------------- *)

(* Gives all inverse order extensions of a poset in child form. *)

(* Utils Needed: AntiChnsIdls[],InvStdTblx[],Relabl[]. *)
(* Data Needed: stdisos*, lookups*, and invexts*, for 4 <= * <= 7, with 
	invexts* stored as the variable invrsex[*] by calling program. *) 

InvExtsWRI[givpst_] := InvExtsWRI[givpst] = Module[{np=Length[givpst]},
	Which[
		np > 7,
		(* For large posets, we find the inverse extensions recursively by 
			breaking the poset into an ideal and its corresponding filter and
			finding their inverse extensions.  These are then joined in all 
			possible ways to give us all inverse order extensions of givpst. *)
		Flatten[
			Map[     (* Combine ideal/filter inverse ext pairs in all ways. *)        
				Outer[Join,#[[1]],#[[2]],1]&,
				Map[              (* Get inverse exts for ideals and filters. *)
					InvStdTblx[givpst,#,InvExtsWRI]&,
					Map[                      (* Create ideal/filter pairs for *)
						{#,Complement[Range[Length[givpst]],#]}&,
						Select[                   (* all ideals of length np/2. *)
							AntiChnsIdls[givpst][[2]],
							(Length[#]\[Equal]Floor[np/2])&
						] 
					],
					{2}
				] 
			],
		2], 
	
		3 < np < 8,
		(* For posets with a length in this range, the inverse extensions
			are found by accessing info in previously created files. *)
		Map[
			Function[x,
				Map[ Ordering[s[givpst]][[#]]&, x ]
			],
			invrsex[np][[ m[Relabl[givpst,Ordering[s[givpst]]]] ]]
		],

		(* For the remaining cases, we can uniquely determine the poset by its
			size and one additional test.  The known inverse extensions for the
			poset are then returned. *)





		np \[Equal] 3 && Flatten[givpst] \[Equal] {},
		{{1,2,3},{1,3,2},{2,1,3},{2,3,1},{3,1,2},{3,2,1}},

		np \[Equal] 3 && Flatten[givpst] \[Equal] {2},
		{{1,2,3},{2,1,3},{2,3,1}},

		np \[Equal] 3 && givpst[[2]] \[Equal] {} && givpst[[3]] \[Equal] {1},
		{{1,2,3},{1,3,2},{2,1,3}},

		np \[Equal] 3 && givpst[[2]] \[Equal] {1} && givpst[[3]] \[Equal] {},
		{{1,2,3},{1,3,2},{3,1,2}},

		np \[Equal] 3 && givpst[[3]] \[Equal] {1,2},
		{{1,2,3},{2,1,3}},

		np \[Equal] 3 && givpst[[2]] \[Equal] {1} && givpst[[3]] \[Equal] {1},
		{{1,2,3},{1,3,2}},

		np \[Equal] 3 && givpst[[2]] \[Equal] {1} && givpst[[3]] \[Equal] {2},
		{{1,2,3}},

		np \[Equal] 2 && givpst[[2]] \[Equal] {},
		{{1,2},{2,1}},

		np \[Equal] 2 && givpst[[2]] \[Equal] {1},
		{{1,2}},

		np \[Equal] 1,
		{{1}}
	] 
];


(* StdFormIso[] --------------------------------------------------------- *)

(* Gives the standard form of givpst and the black-to-yellow transformation 
	to it. *)

(* Utils Needed: PllOff[], NewChdLst[], CmprssBiList[]. *)

StdFormIso[givpst_] := Module[{leng=Length[givpst],purplpst={},labform,
	pairlst,earlst,candid,yel},

	labform = Map[ {givpst[[#]],#}&, Range[Length[givpst]] ];
	pairlst = {{ {{}}, labform }};

	Do[                 (* Iteratively pull off all but one black element. *)
		pairlst = Flatten[
			           (* Replace each pair with a list of descendant pairs. *)
			Map[Function[x, 	
				           (* Each min elt gives rise to one descendant pair. *)
			Map[Function[y,   
					      (* Add this min elt to each black pull-off sequence. *)
					{Map[ Append[#,y]&, x[[1]] ],
					
						                    (* Remove min elt from blue filter. *)
						PllOff[ x[[2]], {y} ]
					}],                                   (* End of Function[y *)
					     (* List of minimal elements in remaining blue filter. *)
					Map[ #[[2]]&, Select[x[[2]],#[[1]]\[Equal]{}&] ]
				]   
		
			],pairlst]                              (* End of Map[Function[x *)

		,1];      (* Flatten merges all the results from various old pairs. *)

		(* Find earliest new yellow child list. *)
		(* Create late dummy object for first rolling comparison. *)
		earlst = Range[leng];

		Do[                                  (* Run thru new list of pairs. *)
			
			candid = Sort[                  (* Order new yellow child lists. *)
	(* Create new yel child list for each part'l black pull-off sequence. *)
				Map[ NewChdLst[givpst,#]&, pairlst[[jf,1]] ]
			][[1]];                     (* ] for Sort[ and then take winner. *)

			                                           (* Rolling Comparison *)
			earlst = If[ Order[earlst,candid] > -1, earlst, candid ]

		,{jf, Length[pairlst]}];                              (* ] for Do[ *)

		(* Add next child list to standard form poset. *)
		AppendTo[purplpst,earlst];

		(* Delete losing partial black pull-off sequences. *)
		pairlst = Map[Function[x,              (* x is one pair in pairlst. *)
			MapAt[Function[y,   (* y is its list of partial black sequences. *)
				Select[y, ( NewChdLst[givpst,#]\[Equal]earlst )& ]
			], x, 1]  
		], pairlst];  

		(* Delete blue filters with no contending pull-off sequences. *)
		pairlst = Select[ pairlst, (#[[1]]\[NotEqual]{})& ];

		(* Compress pairlst when it gets long. *)
		If[ Length[pairlst] > 100, 
			pairlst = CmprssBiList[ pairlst, 2, Flatten[#,1]& ] 
		]
	,{yel,leng}];                                        (* End of Do loop *)

	(* Return {standard form, earliest inverse isomorphism to it}. *)
	{ purplpst, pairlst[[1,1,1]] }
];