Pensieve header: Planet Earth pulled back to the Hopf fibration - one country per continent.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\PlanetHopf"];
<< PlanetHopf-Programs.m

ghosts = {"Canada", "China", "Italy", "SouthAfrica", "Colombia"};
solids = Union[ghosts, {"Mexico", "Japan", "Ghana", "India"}; {}];

MakeColourScheme[AllCountries,{
{"Canada", "Greenland"}, {"Canada", "Russia"}, {"UnitedStates", "Russia"}, {"Canada", "Mexico"}, {"Malaysia", "PapuaNewGuinea"}, {"Japan", "Russia"}, {"Japan", "SouthKorea"}, 
{"Kazakhstan", "Mongolia"}, {"Australia", "NewZealand"}, {"Australia", "Indonesia"}, {"Australia", "PapuaNewGuinea"}, {"China", "Japan"}, {"China", "SouthKorea"}, {"NorthKorea", "Japan"}, {"UnitedStates", "Greenland"}, {"Greenland", "Russia"}, {"Pakistan", "Tajikistan"},ghosts
}];
LoadColourScheme["101204-183102"]

CountryColour /@ ghosts

MakeImage["ColourWheel", Graphics[
{
Hue[c=CountryColour[#]],
Line[{{0,0},{Cos[2Pi c], Sin[2Pi c]}}]
}& /@ AllCountries
]]

MakeImage["BaseMap",Graphics[{
EdgeForm[White],
{
Hue[CountryColour[#]],
CountryShape[#] /. {CountryShape  -> List, Region[pts___] :> Polygon[{pts} /. LonLat-> List]}
}& /@ 
(AllCountries)
}, Background -> Black]]

False && SaveColourScheme[]

beta=(240+1/Sqrt[5])Degree;
MakeImage["FramingExercise", Graphics3D[{
Whirl[#,
WhirlBottom -> 40Degree, WhirlTop -> 320 Degree,WhirlingSteps -> 0
]& /@ AllCountries,
grid
}]]

newwhirl := {
Whirl[#,
WhirlBottom -> 40Degree, WhirlTop -> 320 Degree, WhirlingSteps -> 120,
WhirlRegions -> If[#==="Japan", 4, 1],
TopStyle -> {Glow[Hue[CountryColour[#]]]},
BottomStyle -> {Opacity[1]}
]& /@solids,
Whirl[#,
WhirlBottom -> -40Degree, WhirlTop -> 40 Degree,
WhirlRegions ->If[#==="Japan", 4, 1],
WhirlStyle-> {Opacity[0.1]}, (* was 0.2 *)
TopStyle -> {Opacity[0]}, BottomStyle -> {Opacity[0]}
]& /@ ghosts,
Whirl[#,
WhirlBottom -> -40Degree, WhirlTop -> 40 Degree, WhirlingSteps -> 0,
TopStyle -> {Opacity[1], Glow[Hue[CountryColour[#]]]}, (* was Opacity[0.5] *)
BottomStyle -> {Opacity[1], Glow[Hue[CountryColour[#]]]} (* was Opacity[0.5] *)
]& /@ Complement[AllCountries, {}],
grid
};

beta=(240+1/Sqrt[5])Degree;
MakeImage["NewWhirl", Graphics3D[newwhirl]]

Run["convert -resize 640x640 BaseMap.png BaseMap_640.png"];
Run["convert NewWhirl.png BaseMap_640.png -gravity SouthEast -compose lighten -composite PlanetHopf2.png"];
Run["convert PlanetHopf2.png Label.png -gravity SouthWest -compose lighten -composite PlanetHopf2.png"];
Run["convert -resize 120x120 PlanetHopf2.png PlanetHopf2_120.png"];
Run["convert -resize 720x720 PlanetHopf2.png PlanetHopf2_720.png"];
Run["convert -resize 240x240 PlanetHopf2.png PlanetHopf2_240.png"];
Show[
Import["PlanetHopf2_720.png"],
ImageSize -> 512
]

Dynamic[Show[frame, ImageSize -> 512]]

Do[
fname=StringJoin@@Flatten[{"Frames2/", ToString /@ IntegerDigits[n, 10, 3], ".png"}];
beta=(n+1/Sqrt[5]) Degree;
frame=Rasterize[
Graphics3D[newwhirl, ImageSize -> 720],
RasterSize -> 720, ImageSize -> 720
];
Export[fname, frame],
{n,0,359}
]