120-Cell

Author

Eric W. Weisstein
June 11, 2019

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polytopes/120-Cell.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/120-Cell.html.

©2019 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

Projection and animation from Russell Towle

Original construction

Vertices

EvenPermutationQ[p_]:=Signature[p]==-1
EvenPermutations[l_List]:=Module[{p=Permutations[Range[Length[l]]]},Permutations[l][[Flatten[Position[p,_?EvenPermutationQ,1,Heads->False]]]]
]

pm[n_]:=Flatten[Outer[List,Sequence@@Table[{-1,1},{n}]],n-1]

Cell120Construction:=With[{s=(Sqrt[5]),r=GoldenRatio},
Module[{
vs={
Permutations[2{#1,#2,0,0}]&@@@pm[2],
Permutations[{s#1,#2,#3,#4}]&@@@pm[4],
Permutations[{r#1,r#2,r#3,#4/r^2}]&@@@pm[4],
Permutations[{#1r^2,#2/r,#3/r,#4/r}]&@@@pm[4],
EvenPermutations[{#1r^2,#2/r^2,#3,0}]&@@@pm[3],
EvenPermutations[{#1s,#2/r,#3r,0}]&@@@pm[3],
EvenPermutations[{2#1,#2,#3r,#4/r}]&@@@pm[4]
}
},
Union[Flatten[#,1]]&/@vs
]
]

v=GoldenRatio^2/2Join@@Cell120Construction;

Length/@Cell120Construction

v/.GoldenRatio->ϕ

VertexCount

Length[v]

Distances

d=Union[FullSimplify[EuclideanDistance@@v[[#]]&/@e]]

Circumradius

Max[FullSimplify[Norm/@v]]

Edges

Length[e=Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==1&]]

e

Content

ConvexHullMesh[v]

RegionMeasure[%]

Faces

Sort[FindCycle[Graph[Range[600],UndirectedEdge@@@e],{5},All][[All,All,1]]]

Length[%]

Cells

The boundary of the 120-cell is composed of 120 dodecahedral cells with 4 meeting at each vertex.

Graph

RecognizeGraph[g=Graph[Range[Length[v]],UndirectedEdge@@@e]]

NetCount

2^7 5^2 7^3(2^114 3^78 5^20 7^33+2^47 3^18 5^2 7^12 53^5 2311^3+239^2 3931^2)//N//ScientificForm

New construction [not yet working]

1 from wikipedia (wrong?)

EvenPermutations[l_List]:=Module[{p=AllPermutations[l]},
Pick[p,Signature/@p,1]
]

AllPermutations[l_]:=Module[{z=Count[l,0],n=Length[l]},
Union[Flatten[Permutations[Join[ConstantArray[0,z],#]]&/@Flatten[Outer[List,Sequence@@({-1,1}#&/@DeleteCases[l,0])],n-z-1],1]]
]

v=With[{g=GoldenRatio},
Join[
AllPermutations[{0,0,2,2}],
AllPermutations[{1,1,1,(Sqrt[5])}],
AllPermutations[{(g^(-2)),g,g,g}],
AllPermutations[{(g^(-1)),(g^(-1)),(g^(-1)),(g^2)}],
EvenPermutations[{0,(g^(-2)),1,(g^2)}],
EvenPermutations[{0,(g^(-1)),g,(Sqrt[5])}],
EvenPermutations[{(g^(-1)),1,g,2}]
]];

Length[v]

Length[e=Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==(3.-(Sqrt[5]))&]]

EvenPermutations[l_List]:=Module[{p=AllPermutations[l]},
Pick[p,Signature/@p,-1]
]

v=With[{g=GoldenRatio},
Join[
AllPermutations[{0,0,2,2}],
AllPermutations[{1,1,1,(Sqrt[5])}],
AllPermutations[{(g^(-2)),g,g,g}],
AllPermutations[{(g^(-1)),(g^(-1)),(g^(-1)),(g^2)}],
EvenPermutations[{0,(g^(-2)),1,(g^2)}],
EvenPermutations[{0,(g^(-1)),g,(Sqrt[5])}],
EvenPermutations[{(g^(-1)),1,g,2}]
]];

Length[e=Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==(3.-(Sqrt[5]))&]]

2 (wrong?)

EvenPermutations[l_List]:=Module[{p=AllPermutations[l]},
Pick[p,Signature/@p,1]

AllPermutations[l_]:=Module[{z=Count[l,0],n=Length[l]},
Union[Flatten[Permutations[Join[#,ConstantArray[0,z]]]&/@Flatten[Outer[List,Sequence@@({-1,1}#&/@DeleteCases[l,0])],n-z-1],1]]
]

v=With[{g=GoldenRatio},
Join[
AllPermutations[{2,2,0,0}],
AllPermutations[{(Sqrt[5]),1,1,1}],
AllPermutations[{g,g,g,(g^(-2))}],
AllPermutations[{(g^2),(g^(-1)),(g^(-1)),(g^(-1))}],

EvenPermutations[{(g^2),(g^(-2)),1,0}],
EvenPermutations[{(Sqrt[5]),(g^(-1)),g,0}],
EvenPermutations[{2,1,g,(g^(-1))}]
]];

N[v]//Length

Length[e=Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==(3.-(Sqrt[5]))&]]

Distances

Numeric

Union[N[Norm/@(Subtract@@@Subsets[Cell120,{2}]),20]]//Length//Timing

Union[N[Norm/@(Subtract@@@Subsets[Cell120,{2}]),50]]//Length//Timing

Union[N[Norm/@(Subtract@@@Subsets[Cell120,{2}]),100]]//Length//Timing

...cannot rely on Union of numeric quantities...

Union[N[Norm/@(Subtract@@@Subsets[Cell120,{2}]),20],SameTest->(Abs[#1-#2]<.0001&)]//Length//Timing

Union[Norm/@(Subtract@@@Subsets[Cell120,{2}]),SameTest->(Abs[N[#1-#2,20]]<.0001&)]//Length//Timing

Symbolic

Union[RootReduce[FunctionExpand[Norm/@(Subtract@@@Subsets[Cell120,{2}])]]]//Length//Timing

Skeleton

Embeddings

GraphicsRow[GraphData["HundredTwentyCellGraph","Graph","All"]//StyleGraphs[#,VertexSize->{"Scaled",.02}]&,ImageSize->500]

Scraping

Embeddings from http://en.wikipedia.org/wiki/120-cell

SVGToGraph[svg_,Method->"Wikipedia"]:=Module[{
v=Cases[svg,XMLElement["circle",x__,{}]:>ToExpression[{"cx","cy"}/.x],{1,Infinity}],e=Cases[svg,XMLElement["line",x__,{}]:>ToExpression[{{"x1","y1"},{"x2","y2"}}/.x],{1,Infinity}],
mult=10^2
},
Combinatorica`Graph[List/@(Round[mult e]/mult/.Thread[Round[mult v]/mult->Range[Length[v]]]),List/@v]
]

(g1=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/c/c1/120-cell_graph_H4.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

(g2=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/9/94/120-cell_t0_p20.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

(g3=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/7/78/120-cell_t0_F4.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

ToCommonEdges[#,Combinatorica`Graph["HundredTwentyCellGraph"]]&/@{g1,g2,g3}/500

GetGraphData["HundredTwentyCellGraph","File",#]&/@{"8.0","8.1"}

Graph Properties

Through[{V,M,Girth,Diameter,RegularQ,RegularParameters}[Cell120Graph]]//Timing

ChromaticNumber

χ==3

On 12/2/11 8:17 AM, Stan Wagon wrote:
> Eric:  We got it. This is 3-colorable. At 600 verts it is the largest one we have settled.

l=Import["i600_bfs.txt"];

lines=StringSplit[l,"\n"];

Position[lines,""]

g=MakeSimple@FromAdjacencyLists[ToExpression[Rest/@StringSplit/@lines[[2;;601]]]+1]

RecognizeGraph@g

coloring=Flatten[ToExpression[StringSplit/@lines[[603;;]]]]+1

Length[%]

iso=FindGraphIsomorphism[CombinatoricaGraphToV8Graph@g,GraphData["HundredTwentyCellGraph"]]

Context[InversePermutation]

coloring2=coloring[[InversePermutation[iso[[All,2]]]]]

SetProperty[GraphData["HundredTwentyCellGraph"],System`VertexStyle->MapIndexed[#2[[1]]->{Red,Yellow,Green,Blue}[[#]]&,coloring2]]

coloring2={1,3,3,3,3,2,3,3,1,1,3,3,2,3,1,1,1,1,2,2,3,2,3,3,1,3,2,2,2,1,1,1,2,1,2,3,1,3,3,2,3,1,2,1,3,1,1,3,1,1,2,3,2,2,3,3,2,3,1,1,3,2,2,3,3,3,1,3,1,2,2,2,1,1,1,3,2,1,2,3,3,2,2,3,2,2,3,2,3,1,3,1,3,1,2,1,2,2,2,3,1,2,3,2,1,2,2,3,2,1,1,2,3,2,2,1,1,3,3,2,3,1,2,3,3,1,3,2,3,2,1,3,2,1,2,1,2,3,3,1,3,2,2,3,3,2,2,3,1,2,2,1,3,2,1,1,1,2,3,3,1,3,1,1,3,1,1,1,2,2,3,2,1,2,3,1,3,2,3,2,1,3,2,1,1,2,2,3,2,3,3,1,2,2,2,2,3,3,3,3,3,3,3,1,3,2,3,1,2,3,1,1,3,3,2,3,2,1,3,3,3,2,2,3,1,3,2,3,3,1,1,2,1,2,2,3,2,3,2,3,3,1,3,2,3,3,1,1,2,1,1,2,2,3,1,1,2,3,1,2,1,3,2,1,2,3,2,3,2,2,2,2,3,1,3,2,1,1,3,1,1,3,3,1,1,3,1,1,1,2,2,1,2,3,1,2,2,2,1,3,1,2,1,2,3,2,2,1,3,2,1,1,2,2,2,3,3,2,2,3,1,1,3,2,2,2,1,1,2,2,3,3,3,3,3,2,1,2,1,2,1,1,2,1,3,3,3,3,3,1,2,1,2,3,2,3,3,3,1,2,1,1,1,1,1,2,2,3,1,2,3,3,2,2,3,1,2,2,2,2,2,3,2,3,1,2,2,2,2,2,1,1,1,1,1,1,1,1,2,3,3,1,1,2,3,2,3,1,2,3,3,2,1,2,1,2,2,3,3,1,3,3,3,1,2,2,2,1,1,2,1,1,2,2,1,3,1,3,2,1,3,3,3,2,3,2,2,3,2,1,3,3,1,2,1,1,1,1,3,1,3,3,3,3,1,1,2,2,1,3,1,2,3,2,1,2,1,1,3,2,1,1,1,2,1,1,1,1,2,3,3,2,1,3,1,3,2,1,1,1,3,3,1,3,1,3,1,2,2,2,1,3,1,3,3,2,2,3,3,2,1,3,2,2,2,2,1,3,1,1,3,1,3,3,1,1,3,1,2,3,2,3,1,1,3,3,1,2,2,1,1,1,1,3,1,3,3,2,2,3,2,2,2,3,2,3,3,2,3,1,1,1,3,3,3,1,1,2,2,2,1,1,1,1,2,1,3,2,2,1,3,1,2,3,3,1,3,2,3,2};

ColoringQ[Graph["HundredTwentyCellGraph"],coloring2]

balanced χ==3

Stan Wagon, 12/3/2001

Here is a colored picture of the 120-cell, using a balanced coloring (200/200/200) that Rob P found last night.

Import["/Users/eww/Desktop/PastedGraphic-11.pdf"]

MaximumIndependentVertexSet

Debroni, S.; Delisle, E.; Myrvold, W.; Sethi, A.; Whitney, J.; Woodcock, J.; Fowler, P.~W.; deLa La Vaissi\`ere, B.; and Deza, M.  ``Maximum Independent Sets of the 120-Cell and Other Regular Polyhedra.'  To appear in {\it Ars Mathematica Contemporanea.}

http://www.liga.ens.fr/~deza/withFowler/120-cell_ 2010.pdf

adjl="0 1 2 3 4 1 0 5 6 7 2 0 8 9 10 3 0 11 12 13
4 0 14 15 16 5 1 8 17 18 6 1 11 19 20 7 1 14 21 22
8 2 5 23 24 9 2 12 25 26 10 2 15 27 28 11 3 6 29 30
12 3 9 31 32 13 3 16 33 34 14 4 7 35 36 15 4 10 37 38
16 4 13 39 40 17 5 19 41 42 18 5 21 43 44 19 6 17 45 46
20 6 22 47 48 21 7 18 49 50 22 7 20 51 52 23 8 25 41 53
24 8 27 43 54 25 9 23 55 56 26 9 28 57 58 27 10 24 59 60
28 10 26 61 62 29 11 31 45 63 30 11 33 47 64 31 12 29 55 65
32 12 34 57 66 33 13 30 67 68 34 13 32 69 70 35 14 37 49 71
36 14 39 51 72 37 15 35 59 73 38 15 40 61 74 39 16 36 67 75
40 16 38 69 76 41 17 23 77 78 42 17 44 79 80 43 18 24 81 82
44 18 42 83 84 45 19 29 77 85 46 19 48 79 86 47 20 30 87 88
48 20 46 89 90 49 21 35 81 91 50 21 52 83 92 51 22 36 87 93
52 22 50 89 94 53 23 54 95 96 54 24 53 97 98 55 25 31 77 99
56 25 58 95 100 57 26 32 101 102 58 26 56 103 104 59 27 37 81 105
60 27 62 97 106 61 28 38 101 107 62 28 60 103 108 63 29 64 109 110
64 30 63 111 112 65 31 66 109 113 66 32 65 114 115 67 33 39 87 116
68 33 70 111 117 69 34 40 101 118 70 34 68 114 119 71 35 72 120 121
72 36 71 122 123 73 37 74 120 124 74 38 73 125 126 75 39 76 122 127
76 40 75 125 128 77 41 45 55 129 78 41 80 96 130 79 42 46 131 132
80 42 78 133 134 81 43 49 59 135 82 43 84 98 136 83 44 50 131 137
84 44 82 133 138 85 45 86 110 139 86 46 85 140 141 87 47 51 67 142
88 47 90 112 143 89 48 52 131 144 90 48 88 140 145 91 49 92 121 146
92 50 91 147 148 93 51 94 123 149 94 52 93 147 150 95 53 56 151 152
96 53 78 153 154 97 54 60 151 155 98 54 82 153 156 99 55 100 113 157
100 56 99 158 159 101 57 61 69 160 102 57 104 115 161 103 58 62 151 162
104 58 102 158 163 105 59 106 124 164 106 60 105 165 166 107 61 108 126 167
108 62 107 165 168 109 63 65 169 170 110 63 85 171 172 111 64 68 169 173
112 64 88 171 174 113 65 99 175 176 114 66 70 169 177 115 66 102 175 178
116 67 117 127 179 117 68 116 180 181 118 69 119 128 182 119 70 118 180 183
120 71 73 184 185 121 71 91 186 187 122 72 75 184 188 123 72 93 186 189
124 73 105 190 191 125 74 76 184 192 126 74 107 190 193 127 75 116 194 195
128 76 118 194 196 129 77 130 139 157 130 78 129 197 198 131 79 83 89 199
132 79 134 141 200 133 80 84 153 201 134 80 132 197 202 135 81 136 146 164
136 82 135 203 204 137 83 138 148 205 138 84 137 203 206 139 85 129 207 208
140 86 90 171 209 141 86 132 207 210 142 87 143 149 179 143 88 142 211 212
144 89 145 150 213 145 90 144 211 214 146 91 135 215 216 147 92 94 186 217
148 92 137 215 218 149 93 142 219 220 150 94 144 219 221 151 95 97 103 222
152 95 154 159 223 153 96 98 133 224 154 96 152 198 225 155 97 156 166 226
156 98 155 204 227 157 99 129 228 229 158 100 104 175 230 159 100 152 228 231
160 101 161 167 182 161 102 160 232 233 162 103 163 168 234 163 104 162 232 235
164 105 135 236 237 165 106 108 190 238 166 106 155 236 239 167 107 160 240 241
168 108 162 240 242 169 109 111 114 243 170 109 172 176 244 171 110 112 140 245
172 110 170 208 246 173 111 174 181 247 174 112 173 212 248 175 113 115 158 249
176 113 170 229 250 177 114 178 183 251 178 115 177 233 252 179 116 142 253 254
180 117 119 194 255 181 117 173 253 256 182 118 160 257 258 183 119 177 257 259
184 120 122 125 260 185 120 187 191 261 186 121 123 147 262 187 121 185 216 263
188 122 189 195 264 189 123 188 220 265 190 124 126 165 266 191 124 185 237 267
192 125 193 196 268 193 126 192 241 269 194 127 128 180 270 195 127 188 254 271
196 128 192 258 272 197 130 134 207 273 198 130 154 228 274 199 131 200 205 213
200 132 199 275 276 201 133 202 206 277 202 134 201 275 278 203 136 138 215 279
204 136 156 236 280 205 137 199 281 282 206 138 201 281 283 207 139 141 197 284
208 139 172 229 285 209 140 210 214 286 210 141 209 276 287 211 143 145 219 288
212 143 174 253 289 213 144 199 290 291 214 145 209 290 292 215 146 148 203 293
216 146 187 237 294 217 147 218 221 295 218 148 217 282 296 219 149 150 211 297
220 149 189 254 298 221 150 217 291 299 222 151 223 226 234 223 152 222 300 301
224 153 225 227 277 225 154 224 300 302 226 155 222 303 304 227 156 224 303 305
228 157 159 198 306 229 157 176 208 307 230 158 231 235 308 231 159 230 301 309
232 161 163 240 310 233 161 178 257 311 234 162 222 312 313 235 163 230 312 314
236 164 166 204 315 237 164 191 216 316 238 165 239 242 317 239 166 238 304 318
240 167 168 232 319 241 167 193 258 320 242 168 238 313 321 243 169 244 247 251
244 170 243 322 323 245 171 246 248 286 246 172 245 322 324 247 173 243 325 326
248 174 245 325 327 249 175 250 252 308 250 176 249 323 328 251 177 243 329 330
252 178 249 329 331 253 179 181 212 332 254 179 195 220 333 255 180 256 259 334
256 181 255 326 335 257 182 183 233 336 258 182 196 241 337 259 183 255 330 338
260 184 261 264 268 261 185 260 339 340 262 186 263 265 295 263 187 262 339 341
264 188 260 342 343 265 189 262 342 344 266 190 267 269 317 267 191 266 340 345
268 192 260 346 347 269 193 266 346 348 270 194 271 272 334 271 195 270 343 349
272 196 270 347 350 273 197 274 278 351 274 198 273 302 352 275 200 202 281 353
276 200 210 290 354 277 201 224 355 356 278 202 273 355 357 279 203 280 283 358
280 204 279 305 359 281 205 206 275 360 282 205 218 291 361 283 206 279 356 362
284 207 285 287 351 285 208 284 324 363 286 209 245 364 365 287 210 284 364 366
288 211 289 292 367 289 212 288 327 368 290 213 214 276 369 291 213 221 282 370
292 214 288 365 371 293 215 294 296 358 294 216 293 341 372 295 217 262 373 374
296 218 293 373 375 297 219 298 299 367 298 220 297 344 376 299 221 297 374 377
300 223 225 303 378 301 223 231 312 379 302 225 274 355 380 303 226 227 300 381
304 226 239 313 382 305 227 280 356 383 306 228 307 309 352 307 229 306 328 363
308 230 249 384 385 309 231 306 384 386 310 232 311 314 387 311 233 310 331 388
312 234 235 301 389 313 234 242 304 390 314 235 310 385 391 315 236 316 318 359
316 237 315 345 372 317 238 266 392 393 318 239 315 392 394 319 240 320 321 387
320 241 319 348 395 321 242 319 393 396 322 244 246 325 397 323 244 250 329 398
324 246 285 364 399 325 247 248 322 400 326 247 256 330 401 327 248 289 365 402
328 250 307 384 403 329 251 252 323 404 330 251 259 326 405 331 252 311 385 406
332 253 333 335 368 333 254 332 349 376 334 255 270 407 408 335 256 332 407 409
336 257 337 338 388 337 258 336 350 395 338 259 336 408 410 339 261 263 342 411
340 261 267 346 412 341 263 294 373 413 342 264 265 339 414 343 264 271 347 415
344 265 298 374 416 345 267 316 392 417 346 268 269 340 418 347 268 272 343 419
348 269 320 393 420 349 271 333 407 421 350 272 337 408 422 351 273 284 423 424
352 274 306 423 425 353 275 354 357 426 354 276 353 366 427 355 277 278 302 428
356 277 283 305 429 357 278 353 424 430 358 279 293 431 432 359 280 315 431 433
360 281 361 362 426 361 282 360 375 434 362 283 360 432 435 363 285 307 423 436
364 286 287 324 437 365 286 292 327 438 366 287 354 424 439 367 288 297 440 441
368 289 332 440 442 369 290 370 371 427 370 291 369 377 434 371 292 369 441 443
372 294 316 431 444 373 295 296 341 445 374 295 299 344 446 375 296 361 432 447
376 298 333 440 448 377 299 370 441 449 378 300 379 380 450 379 301 378 386 451
380 302 378 425 452 381 303 382 383 450 382 304 381 394 453 383 305 381 433 454
384 308 309 328 455 385 308 314 331 456 386 309 379 425 457 387 310 319 458 459
388 311 336 458 460 389 312 390 391 451 390 313 389 396 453 391 314 389 459 461
392 317 318 345 462 393 317 321 348 463 394 318 382 433 464 395 320 337 458 465
396 321 390 459 466 397 322 398 399 467 398 323 397 403 468 399 324 397 436 469
400 325 401 402 467 401 326 400 409 470 402 327 400 442 471 403 328 398 436 472
404 329 405 406 468 405 330 404 410 470 406 331 404 460 473 407 334 335 349 474
408 334 338 350 475 409 335 401 442 476 410 338 405 460 477 411 339 412 413 478
412 340 411 417 479 413 341 411 444 480 414 342 415 416 478 415 343 414 421 481
416 344 414 448 482 417 345 412 444 483 418 346 419 420 479 419 347 418 422 481
420 348 418 465 484 421 349 415 448 485 422 350 419 465 486 423 351 352 363 487
424 351 357 366 488 425 352 380 386 489 426 353 360 490 491 427 354 369 490 492
428 355 429 430 452 429 356 428 435 454 430 357 428 491 493 431 358 359 372 494
432 358 362 375 495 433 359 383 394 496 434 361 370 490 497 435 362 429 491 498
436 363 399 403 499 437 364 438 439 469 438 365 437 443 471 439 366 437 492 500
440 367 368 376 501 441 367 371 377 502 442 368 402 409 503 443 371 438 492 504
444 372 413 417 505 445 373 446 447 480 446 374 445 449 482 447 375 445 497 506
448 376 416 421 507 449 377 446 497 508 450 378 381 509 510 451 379 389 509 511
452 380 428 510 512 453 382 390 509 513 454 383 429 510 514 455 384 456 457 472
456 385 455 461 473 457 386 455 511 515 458 387 388 395 516 459 387 391 396 517
460 388 406 410 518 461 391 456 511 519 462 392 463 464 483 463 393 462 466 484
464 394 462 513 520 465 395 420 422 521 466 396 463 513 522 467 397 400 523 524
468 398 404 523 525 469 399 437 524 526 470 401 405 523 527 471 402 438 524 528
472 403 455 525 529 473 406 456 525 530 474 407 475 476 485 475 408 474 477 486
476 409 474 527 531 477 410 475 527 532 478 411 414 533 534 479 412 418 533 535
480 413 445 534 536 481 415 419 533 537 482 416 446 534 538 483 417 462 535 539
484 420 463 535 540 485 421 474 537 541 486 422 475 537 542 487 423 488 489 499
488 424 487 493 500 489 425 487 512 515 490 426 427 434 543 491 426 430 435 544
492 427 439 443 545 493 430 488 512 546 494 431 495 496 505 495 432 494 498 506
496 433 494 514 520 497 434 447 449 547 498 435 495 514 548 499 436 487 526 529
500 439 488 526 549 501 440 502 503 507 502 441 501 504 508 503 442 501 528 531
504 443 502 528 550 505 444 494 536 539 506 447 495 536 551 507 448 501 538 541
508 449 502 538 552 509 450 451 453 553 510 450 452 454 554 511 451 457 461 555
512 452 489 493 556 513 453 464 466 557 514 454 496 498 558 515 457 489 529 559
516 458 517 518 521 517 459 516 519 522 518 460 516 530 532 519 461 517 530 560
520 464 496 539 561 521 465 516 540 542 522 466 517 540 562 523 467 468 470 563
524 467 469 471 564 525 468 472 473 565 526 469 499 500 566 527 470 476 477 567
528 471 503 504 568 529 472 499 515 569 530 473 518 519 570 531 476 503 541 571
532 477 518 542 572 533 478 479 481 573 534 478 480 482 574 535 479 483 484 575
536 480 505 506 576 537 481 485 486 577 538 482 507 508 578 539 483 505 520 579
540 484 521 522 580 541 485 507 531 581 542 486 521 532 582 543 490 544 545 547
544 491 543 546 548 545 492 543 549 550 546 493 544 549 583 547 497 543 551 552
548 498 544 551 584 549 500 545 546 585 550 504 545 552 586 551 506 547 548 587
552 508 547 550 588 553 509 554 555 557 554 510 553 556 558 555 511 553 559 560
556 512 554 559 583 557 513 553 561 562 558 514 554 561 584 559 515 555 556 589
560 519 555 562 590 561 520 557 558 591 562 522 557 560 592 563 523 564 565 567
564 524 563 566 568 565 525 563 569 570 566 526 564 569 585 567 527 563 571 572
568 528 564 571 586 569 529 565 566 589 570 530 565 572 590 571 531 567 568 593
572 532 567 570 594 573 533 574 575 577 574 534 573 576 578 575 535 573 579 580
576 536 574 579 587 577 537 573 581 582 578 538 574 581 588 579 539 575 576 591
580 540 575 582 592 581 541 577 578 593 582 542 577 580 594 583 546 556 584 595
584 548 558 583 596 585 549 566 586 595 586 550 568 585 597 587 551 576 588 596
588 552 578 587 597 589 559 569 590 595 590 560 570 589 598 591 561 579 592 596
592 562 580 591 598 593 571 581 594 597 594 572 582 593 598 595 583 585 589 599
596 584 587 591 599 597 586 588 593 599 598 590 592 594 599 599 595 596 597 598";

g=MakeSimple@FromAdjacencyLists[Partition[FromDigits/@StringSplit[adjl,{" ","\n"}]+1,5]]

RecognizeGraph[g]

indset=1+FromDigits/@StringSplit["0 5 6 9 10 13 14 21 22 23 24 29 32 37 39
42 46 47 55 58 60 61 64 68 69 71 74 76 78 81
83 85 89 90 91 93 95 98 100 102 105 108 109 113 114
116 119 122 129 132 133 136 138 142 148 150 154 155 162 167
171 172 173 178 182 185 186 190 193 194 195 196 197 199 202
210 211 216 217 220 222 227 228 229 230 232 236 242 243 248
249 253 259 260 263 265 267 274 277 280 281 282 283 284 286
289 290 292 293 297 300 304 309 311 312 316 317 318 319 322
324 326 328 329 333 334 335 336 343 346 348 350 357 366 370
373 374 375 379 380 381 385 390 391 398 400 406 410 411 414
417 419 421 423 426 427 428 431 433 435 436 437 440 441 442
443 455 458 462 465 466 470 475 476 480 482 489 493 495 497
500 505 507 508 509 510 511 514 517 518 520 524 525 528 529
533 535 537 540 542 544 545 551 556 557 560 563 566 570 571
574 579 581 584 586 588 589 592 594 599",{" ","\n"}]

Length[%]

iso=FindGraphIsomorphism[CombinatoricaGraphToV8Graph@g,GraphData["HundredTwentyCellGraph"]]

indset2=Sort[indset/.iso]

IndependentVertexSetQ[GraphData["HundredTwentyCellGraph"],indset2]

Spectrum

GraphData["HundredTwentyCellGraph","Spectrum"]//SpectrumForm//TraditionalForm

CyclePolynomial

A167984

GraphData["HundredTwentyCellGraph","CyclePolynomial"]

ListPlot[%[[2]],Filling->Automatic,PlotRange->All]

PathPolynomial

GraphData["HundredTwentyCellGraph","PathPolynomial"]

Numbers of Vertices at Distance n

Tally[Sort[Flatten@Normal[GraphDistanceMatrix[GraphData["HundredTwentyCellGraph"]]]]]

Max[System`GraphDistanceMatrix[GraphData["HundredTwentyCellGraph"]]]

?Distances

Tally[Distances[Graph["HundredTwentyCellGraph"],1]]

%[[All,2]]

Antipodal

p=Position[System`GraphDistanceMatrix[g=GraphData["HundredTwentyCellGraph"]],15];

rules=Rule@@@Union[Sort/@p]

EdgeList[g]/.rules

GraphData["CubicalGraph"]//InputForm

VertexDelete[g,rules[[All,1]]]

System`Graph[VertexDelete[VertexList[g],rules[[All,1]]],Union[EdgeList[g]/.rules]]

Syst

?Graph

Graph[VertexSet

?Edges

Graphic

spc={{1,2,3},{1,2,4},{1,3,4},{2,3,4}};

d=Union[ Map[N[Norm[First@v533-#]]&, Rest@v533],
SameTest->(Chop[#1-#2]==0&)];
c=Table[
a=Drop[v533,i-1];
{First@a,#}& /@ Select[Rest@a, N[Norm[First@a-#]]<N[d[[2]]]&],
{i,Length[v533]}];
v=Map[#[[ spc[[1]] ]]&, v533];
g=Map[#[[ spc[[1]] ]]&, Flatten[c,1], {-2} ];
Show[Graphics3D[{Line /@ Union[g],PointSize[.02],Point/@v} ],
Boxed->False,
ViewPoint->{0,0,200}];

gr=FromEdges[v533,c];
ShowGraph[gr]

Animation

FromEdges[v_List,e_List]:=Module[{i},
FromUnorderedPairs[Flatten[e,1]/.Thread[Table[v[[i]]->i,{i,Length[v]}]]]
]

(* Animation *)
(* r= which 3-space:1(w=0),2(z=0),3(y=0),4(x=0)*)
(* t= PlotRange*)

PolytopeMovie[vertices_List,ang_List:{0,Pi,Pi/30},r_:1,t_:2,opts___]:=Module[{v,d,c,a,v1,g},
Table[v=(rota4[#1,i,i]&)/@vertices;
d=Union[(N[Norm[v[[1]]-#1]]&)/@Rest[v],SameTest->(Chop[#1-#2]==0&)];
c=Table[a=Drop[v,i-1]; ({First[a],#1}&)/@Select[Rest[a],Chop[N[Norm[First[a]-#1]]-d[[1]]]==0&],{i,Length[v]}];
v1=(#1[[spc[[r]]]]&)/@v;
g=Map[#1[[spc[[r]]]]&,Flatten[c,1],{-2}];
Show[Graphics3D[{Line/@Union[g],PointSize[0.02],Point/@v1}],Boxed->False,PlotRange->{{-t,t},{-t,t},{-t,t}},opts],{i,ang[[1]],ang[[2]]-ang[[3]],ang[[3]]}]
]

movie=PolytopeMovie[v533,{0,Pi/2,Pi/30},1,3,ViewPoint->{0,0,2}];

Export[gifs<>"cell120.gif",movie,
"GIF",ImageSize->200,AnimationDirection->ForwardBackward]