<<<<Deal with equalities in 2 good situations (when there is a line) and dynamically disable continuous action to extend range of applet>>>>

ButtonControl[Dynamic[s_]]:=Row[{Button["-",If[s≠3,--s]],Button["+",If[s≠6,++s]]}]

feasible[valuesFirst_,valuesSecond_,plane_]:=Module[{values1=valuesFirst,values2=valuesSecond,first,same,ratio,ratios={},pay1,pay2={},pts={},pt={0,0,0},index,j=1},
Which[plane=="xy",first=1,plane=="yz",first=2,plane=="zx",first=3];
While[j≤Length[values1],ratio=values1[[j]]/values2[[j]];same=Position[ratios,ratio];If[same=={},j++;AppendTo[ratios,ratio],values1=ReplacePart[values1,same[[1,1]]->values1[[same[[1,1]]]]+values1[[j]]];values2=ReplacePart[values2,same[[1,1]]->values2[[same[[1,1]]]]+values2[[j]]];
values1=Delete[values1,j];values2=Delete[values2,j]]];
pay1=values1;
pt[[first]]=Plus@@pay1;pt[[Mod[first,3]+1]]=0;pt[[Mod[first+1,3]+1]]=0;AppendTo[pts,pt];
Do[index=Ordering[ratios][[i]];pay1=ReplacePart[pay1,index->0];AppendTo[pay2,values2[[index]]];pt[[first]]=Plus@@pay1;pt[[Mod[first,3]+1]]=Plus@@pay2;pt[[Mod[first+1,3]+1]]=0;AppendTo[pts,pt],{i,Length[values1]}];pay1={};pay2=values2;
Do[index=Ordering[ratios][[i]];pay2=ReplacePart[pay2,index->0];AppendTo[pay1,values1[[index]]];pt[[first]]=Plus@@pay1;pt[[Mod[first,3]+1]]=Plus@@pay2;pt[[Mod[first+1,3]+1]]=0;AppendTo[pts,pt],{i,Length[values1]-1}];
pts]

feasible3D[aValues_,bValues_,cValues_]:=Module[{abPayoff=feasible[aValues,bValues,"xy"],caPayoff=feasible[cValues,aValues,"zx"],bcPayoff=feasible[bValues,cValues,"yz"],sideLength,Points,CoordinateFaces,side1Top,side2Top,side3Top,side1Bottom,side2Bottom,side3Bottom,potentialTopCenters,potentialBottomCenters,potentialTopNormals={},potentialBottomNormals={},topPoints={},bottomPoints={},top={},bottom={},oneSide,plane,left,right,ltick,rtick,normal,rnormal,rightEnd,allocations=Tuples[{1,2,3},Length[aValues]],person={aValues,bValues,cValues},interiorPoints={},pt={0,0,0},topNormals,bottomNormals,oldtop,oldbottom,newtop,newbottom,newNormals,levels,coplanar},
Points=Join[abPayoff[[;;Length[abPayoff]/2]],bcPayoff[[;;Length[bcPayoff]/2]],caPayoff,bcPayoff[[Length[bcPayoff]/2+1;;]],abPayoff[[Length[abPayoff]/2+1;;]]];
CoordinateFaces={Join[Range[Length[abPayoff]/2],Range[Length[Points]-Length[abPayoff]/2+1,Length[Points]]],Join[Length[abPayoff]/2+Range[Length[bcPayoff]/2],Range[Length[Points]-Length[abPayoff]/2-Length[bcPayoff]/2+1,Length[Points]-Length[abPayoff]/2]],Length[abPayoff]/2+Length[bcPayoff]/2+Range[Length[caPayoff]]};
side1Top=Range[Length[abPayoff]/2];
side2Top=Length[abPayoff]/2+Range[Length[bcPayoff]/2];
side3Top=Length[abPayoff]/2+Length[bcPayoff]/2+Range[Length[caPayoff]/2];
side1Bottom=Length[Points]/2+Range[Length[caPayoff]/2];
side2Bottom=Length[Points]/2+Length[caPayoff]/2+Range[Length[bcPayoff]/2];
side3Bottom=Length[Points]/2+Length[caPayoff]/2+Length[bcPayoff]/2+Range[Length[abPayoff]/2];
potentialTopCenters=Tuples[{side1Top[[2;;]],side2Top[[2;;]],side3Top[[2;;]]}];
potentialBottomCenters=Tuples[{side1Bottom[[2;;]],side3Bottom[[2;;]],side2Bottom[[2;;]]}];
Do[AppendTo[potentialTopNormals,(Points[[potentialTopCenters[[i,2]]]]-Points[[potentialTopCenters[[i,1]]]])\[Cross](Points[[potentialTopCenters[[i,3]]]]-Points[[potentialTopCenters[[i,1]]]])],{i,Length[potentialTopCenters]}];
Do[AppendTo[topPoints,Points[[Join[side1Top,side2Top,side3Top][[i]]]]],{i,Length[Points]/2}];
Do[oneSide=0;plane=potentialTopNormals[[i]].Points[[potentialTopCenters[[i,1]]]];Do[If[potentialTopNormals[[i]].topPoints[[j]]>plane,oneSide++];If[oneSide>0,Break[]],{j,Length[topPoints]}];If[oneSide==0,AppendTo[top,potentialTopCenters[[i]]]];,{i,Length[potentialTopNormals]}];
top={Union[Flatten[top]]};
Do[AppendTo[potentialBottomNormals,(Points[[potentialBottomCenters[[i,2]]]]-Points[[potentialBottomCenters[[i,1]]]])\[Cross](Points[[potentialBottomCenters[[i,3]]]]-Points[[potentialBottomCenters[[i,1]]]])],{i,Length[potentialBottomCenters]}];
Do[AppendTo[bottomPoints,Points[[Join[side1Bottom,side2Bottom,side3Bottom][[i]]]]],{i,Length[Points]/2}];
Do[oneSide=0;plane=potentialBottomNormals[[i]].Points[[potentialBottomCenters[[i,1]]]];Do[If[potentialBottomNormals[[i]].bottomPoints[[j]]<plane,oneSide++];If[oneSide>0,Break[]],{j,Length[bottomPoints]}];If[oneSide==0,AppendTo[bottom,potentialBottomCenters[[i]]]];,{i,Length[potentialBottomNormals]}];
bottom={Union[Flatten[bottom]]};
Do[Do[If[topSide,
right=Which[c==1,Range[Select[top[[1]],#≤Length[side1Top]&][[1]]],c==2,Range[Length[side1Top]+1,Select[top[[1]],Length[side1Top]<#≤Length[Join[side1Top,side2Top]] &][[1]]],c==3,Range[Length[Join[side1Top,side2Top]]+1,Select[top[[1]],Length[Join[side1Top,side2Top]]<# &][[1]]]];
left=Which[c==1,Range[Length[Join[side1Top,side2Top,side3Top]],Select[top[[1]],Length[Join[side1Top,side2Top]]<# &][[-1]],-1],c==2,Range[Length[side1Top],Select[top[[1]],#≤Length[side1Top]&][[-1]],-1],c==3,Range[Length[Join[side1Top,side2Top]],Select[top[[1]],Length[side1Top]<#≤Length[Join[side1Top,side2Top]] &][[-1]],-1]];,
right=Which[c==1,Range[Length[Join[side1Top,side2Top,side3Top]]+1,Select[bottom[[1]],#≤Length[Join[side1Top,side2Top,side3Top,side1Bottom]]&][[1]]],c==2,Range[Length[Join[side1Top,side2Top,side3Top,side1Bottom]]+1,Select[bottom[[1]],Length[Join[side1Top,side2Top,side3Top,side1Bottom]]<#≤Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]] &][[1]]],c==3,Range[Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]]+1,Select[bottom[[1]],Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]]<# &][[1]]]];
left=Which[c==1,Range[Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom,side3Bottom]],Select[bottom[[1]],Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]]<# &][[-1]],-1],c==2,Range[Length[Join[side1Top,side2Top,side3Top,side1Bottom]],Select[bottom[[1]],#≤Length[Join[side1Top,side2Top,side3Top,side1Bottom]]&][[-1]],-1],c==3,Range[Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]],Select[bottom[[1]],Length[Join[side1Top,side2Top,side3Top,side1Bottom]]<#≤Length[Join[side1Top,side2Top,side3Top,side1Bottom,side2Bottom]] &][[-1]],-1]]];
If[topSide,AppendTo[top,{right[[1]],right[[2]],left[[1]]}],AppendTo[bottom,{right[[1]],right[[2]],left[[1]]}]];rtick=2;ltick=1;
Do[normal=If[rtick>ltick,(Points[[right[[rtick]]]]-Points[[right[[rtick-1]]]])\[Cross](Points[[left[[ltick]]]]-Points[[right[[rtick-1]]]]),(Points[[left[[ltick]]]]-Points[[left[[ltick-1]]]])\[Cross](Points[[right[[rtick]]]]-Points[[left[[ltick-1]]]])];
If[rtick≠Length[right],rightEnd=False;rnormal=(Points[[right[[rtick+1]]]]-Points[[right[[rtick]]]])\[Cross](Points[[left[[ltick]]]]-Points[[right[[rtick]]]]),rightEnd=True];
If[ltick==Length[left]||(!rightEnd&&rnormal.Points[[right[[rtick]]]]>rnormal.Points[[left[[ltick+1]]]]),
If[normal.Points[[right[[rtick]]]]==normal.Points[[right[[rtick+1]]]],If[topSide,AppendTo[top[[-1]],right[[rtick+1]]],AppendTo[bottom[[-1]],right[[rtick+1]]]],If[topSide,AppendTo[top,{right[[rtick]],right[[rtick+1]],left[[ltick]]}],AppendTo[bottom,{right[[rtick]],right[[rtick+1]],left[[ltick]]}]]];rtick++;,
If[normal.Points[[right[[rtick]]]]==normal.Points[[left[[ltick+1]]]],If[topSide,AppendTo[top[[-1]],left[[ltick+1]]],AppendTo[bottom[[-1]],left[[ltick+1]]]],If[topSide,AppendTo[top,{right[[rtick]],left[[ltick]],left[[ltick+1]]}],AppendTo[bottom,{right[[rtick]],left[[ltick]],left[[ltick+1]]}]]];ltick++];
,{Length[Join[left,right]]-3}],{c,3}],{topSide,{True,False}}];
Do[top[[i]]=Sort[top[[i]]],{i,2,Length[top]}];
Do[bottom[[i]]=Sort[bottom[[i]]],{i,2,Length[bottom]}];
allocations=Extract[allocations,Take[Select[MapIndexed[Flatten[{DeleteDuplicates[#1],#2}]&,allocations],Length[#]==4&],All,-1]];
Do[Do[pt[[allocations[[i,j]]]]+=person[[allocations[[i,j]],j]],{j,Length[aValues]}];AppendTo[interiorPoints,pt];
pt={0,0,0};,{i,Length[allocations]}];
topNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@top;
bottomNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@bottom;
Do[oldtop=Pick[Range[Length[top]],MapThread[GreaterEqual,{topNormals.pay,topNormals[[#]].Points[[top[[#,1]]]]&/@Range[Length[top]]}]];
If[oldtop≠{},
(* condition true *)
AppendTo[Points,pay];newtop=top[[oldtop]];newtop=#[[1]]&/@Select[Tally[Flatten[Partition[Append[#,#[[1]]],2,1]&/@newtop,1],#1[[1]]==#2[[2]]&&#1[[2]]==#2[[1]]&],#[[2]]==1&];newtop=Append[#,Length[Points]]&/@newtop;
newNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@newtop;
newNormals=#/Norm[#]&/@newNormals;
levels=(newNormals[[#]].Points[[newtop[[#,1]]]]&/@Range[Length[newtop]]);
levels=MapThread[Append,{newNormals,levels}];
coplanar=(#[[1]]&/@Select[Tally[levels],#[[2]]≠1&]);
If[coplanar≠{},coplanar=Position[levels,#]&/@coplanar;
Do[AppendTo[newtop,Flatten[Extract[newtop,#]&/@i,1]],{i,coplanar}];
(*May have problems with order of joined faces: Don't Delete duplicates!!!*)
newtop=Delete[newtop,Flatten[coplanar,1]];newNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@newtop;];
top=Join[top,newtop];topNormals=Join[topNormals,newNormals];top=Delete[top,Partition[oldtop,1]];topNormals=Delete[topNormals,Partition[oldtop,1]];,
(* oldtop == {} *)
oldbottom=Pick[Range[Length[bottom]],MapThread[GreaterEqual,{bottomNormals.pay,bottomNormals[[#]].Points[[bottom[[#,1]]]]&/@Range[Length[bottom]]}]];
If[oldbottom≠{},AppendTo[Points,pay];newbottom=bottom[[oldbottom]];newbottom=#[[1]]&/@Select[Tally[Flatten[Partition[Append[#,#[[1]]],2,1]&/@newbottom,1],#1[[1]]==#2[[2]]&&#1[[2]]==#2[[1]]&],#[[2]]==1&];newbottom=Append[#,Length[Points]]&/@newbottom;
newNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@newbottom;
newNormals=#/Norm[#]&/@newNormals;
levels=(newNormals[[#]].Points[[newbottom[[#,1]]]]&/@Range[Length[newbottom]]);
levels=MapThread[Append,{newNormals,levels}];
coplanar=(#[[1]]&/@Select[Tally[levels],#[[2]]≠1&]);
If[coplanar≠{},coplanar=Position[levels,#]&/@coplanar;
Do[AppendTo[newbottom,Flatten[Extract[newbottom,#]&/@i,1]],{i,coplanar}];
newbottom=Delete[newbottom,Flatten[coplanar,1]];newNormals=((Points[[#[[2]]]]-Points[[#[[1]]]])\[Cross](Points[[#[[3]]]]-Points[[#[[1]]]]))&/@newbottom;];
bottom=Join[bottom,newbottom];bottomNormals=Join[bottomNormals,newNormals];bottom=Delete[bottom,Partition[oldbottom,1]];bottomNormals=Delete[bottomNormals,Partition[oldbottom,1]];]];
,{pay,interiorPoints}];
{Points,CoordinateFaces,bottom,top,topNormals,bottomNormals}]

equitable[feasiblelist_,type_,aValues_,bValues_,cValues_]:=Module[{top,bottom,topNormals,bottomNormals,points,first,second,third,t,potentialTopPts={},potentialBottomPts={},bounds,interior,count=0,pts={}},
top=feasiblelist[[4]];bottom=feasiblelist[[3]];topNormals=feasiblelist[[5]];bottomNormals=feasiblelist[[6]];points=feasiblelist[[1]];
If[type=="Value",first=1;second=1;third=1,first=Plus@@aValues;second=Plus@@bValues;third=Plus@@cValues];
Do[t=topNormals[[i]].points[[top[[i,1]]]]/topNormals[[i]].{first,second,third};AppendTo[potentialTopPts,{t*first,t*second,t*third}],{i,Length[top]}];
Do[t=bottomNormals[[i]].points[[bottom[[i,1]]]]/bottomNormals[[i]].{first,second,third};AppendTo[potentialBottomPts,{t*first,t*second,t*third}],{i,Length[bottom]}];
Do[bounds=#[[1]]&/@Select[Tally[Partition[Append[top[[i]],top[[i,1]]],2,1],#1[[1]]==#2[[2]]&&#1[[2]]==#2[[1]]&],#[[2]]==1&];
Do[interior=topNormals[[i]]\[Cross](points[[bounds[[j,2]]]]-points[[bounds[[j,1]]]]);If[interior.potentialTopPts[[i]]≥interior.points[[bounds[[j,1]]]],count++,Break[]],{j,Length[bounds]}];
If[count==Length[bounds],AppendTo[pts,potentialTopPts[[i]]];count=0;Break[],count=0],
{i,Length[top]}];
Do[bounds=#[[1]]&/@Select[Tally[Partition[Append[bottom[[i]],bottom[[i,1]]],2,1],#1[[1]]==#2[[2]]&&#1[[2]]==#2[[1]]&],#[[2]]==1&];
Do[interior=bottomNormals[[i]]\[Cross](points[[bounds[[j,2]]]]-points[[bounds[[j,1]]]]);If[interior.potentialBottomPts[[i]]≥interior.points[[bounds[[j,1]]]],count++,Break[]],{j,Length[bounds]}];
If[count==Length[bounds],AppendTo[pts,potentialBottomPts[[i]]];Break[],count=0],
{i,Length[bottom]}];pts]

defaultGoods=4;
Manipulate[
TabView[Table[With[{j=j},j ->Dynamic[Refresh[
aValues[[1]]=bValues[[1]]=cValues[[1]]=$;
If[currentNumGoods<numGoods,currentNumGoods=numGoods;AppendTo[aValues,RandomInteger[{1,100}]];AppendTo[bValues,RandomInteger[{1,100}]];AppendTo[cValues,RandomInteger[{1,100}]]];
If[currentNumGoods>numGoods,currentNumGoods=numGoods;aValues=Drop[aValues,-1];bValues=Drop[bValues,-1];cValues=Drop[cValues,-1]];
If[currentGood≠goods,currentGood=goods;a=aValues[[goods]];b=bValues[[goods]];c=cValues[[goods]],aValues[[goods]]=a;bValues[[goods]]=b;cValues[[goods]]=c];
If[goods>Length[aValues],goods=goods-1];
feasibleList=feasible3D[aValues,bValues,cValues];
maxX=Flatten[Select[feasibleList[[1]],#[[2]]==#[[3]]==0&]][[1]];
maxY=Flatten[Select[feasibleList[[1]],#[[1]]==#[[3]]==0&]][[2]];
maxZ=Flatten[Select[feasibleList[[1]],#[[1]]==#[[2]]==0&]][[3]];
(*If[j=="Shares",axes=All;ticks=Table[Table[{i(n/10),10i},{i,0,10}],{n,{maxX,maxY,maxZ}}],axes={{0,Max[maxX,maxY,maxZ]},{0,Max[maxX,maxY,maxZ]},{0,Max[maxX,maxY,maxZ]}};ticks=Automatic];*)
Graphics3D[{Opacity[.7],Blue,GraphicsComplex[feasibleList[[1]],Polygon[Join[feasibleList[[2]],feasibleList[[3]]]]],
(*Line[{feasibleList[[1]],feasibleList[[Length[feasibleList]/2+1]]}],
RGBColor[.25,.75,.5],If[evf,Polygon[envyFree[feasibleList]]],If[evf,Line[{{maxX/2,maxY/2},{maxX/2,maxY/2}}]],
*)Opacity[1],Thickness[.01],Orange,If[equV,Line[equitable[feasibleList,"Value",aValues,bValues,cValues]]],
Purple,If[equS,Line[equitable[feasibleList,"Share",aValues,bValues,cValues]]],
Opacity[.6],If[eff,Red,Blue],GraphicsComplex[feasibleList[[1]],Polygon[feasibleList[[4]]]]},
Axes->True,AspectRatio->1/1,Boxed->False,AxesEdge->{{-1,-1},{-1,-1},{-1,-1}}(*PlotRegion->{{0,.95},{0,.95}},AxesLabel->{"Tabatha's Payoff","Darnell's Payoff","Li's Payoff"},PlotRange->axes,Ticks->ticks*)],TrackedSymbols->{goods,numGoods,a,b,c,$,eff,equS,equV,evf}](*,SynchronousUpdating->False*)]],{j,{"Payoffs","Shares"}}],Enabled->False],Row[{Control[{{goods,2,""},Table[i->"Good "<>ToString[i-1],{i,2,numGoods}],ControlType->PopupMenu}],Control[{{numGoods,defaultGoods,""},ButtonControl[#]&}]}],
{{$,RandomInteger[{1,100}],"Amount of Money"},1,100,1,ControlType->Slider,Appearance->"Labeled"},{{aValues,Flatten[{{$},Table[ RandomInteger[{1,100}],{defaultGoods-1}]}]},ControlType->None},{{a,1,"Tabatha's Valuation"},1,100,1,ControlType->Slider,Appearance->"Labeled"},{{bValues,Flatten[{{$},Table[ RandomInteger[{1,100}],{defaultGoods-1}]}]},ControlType->None},{{b,1,"Darnell's Valuation"},1,100,1,ControlType->Slider,Appearance->"Labeled"},
{{cValues,Flatten[{{$},Table[ RandomInteger[{1,100}],{defaultGoods-1}]}]},ControlType->None},{{c,1,"Li's Valuation"},1,100,1,ControlType->Slider,Appearance->"Labeled"},{{currentNumGoods,defaultGoods},ControlType->None},{{currentGood,1},ControlType->None},
OpenerView[{"Table of Valuations",Dynamic[TableForm[{aValues[[2;;]],bValues[[2;;]],cValues[[2;;]]},TableHeadings->{{"Tabatha","Darnell","Li"},Table[i,{i,Length[aValues-1]}]}]]}],Row[{Control[{{eff,False,Style["Efficient",FontColor->RGBColor[.8,0,.2]]},{True,False}}],Control[{{equS,False,Style["Share Equitable",FontColor->RGBColor[.5,0,.6]]},{True,False},Enabled->True}],Control[{{equV,False,Style["Value Equitable",FontColor->RGBColor[.7,.3,.2]]},{True,False},Enabled->True}],Control[{{evf,False,Style["Envy Free",FontColor->RGBColor[0,.5,.5]]},{True,False},Enabled->False}]},Spacer[10]],SaveDefinitions->True]