Last active
March 16, 2022 06:14
-
-
Save stla/2ed8d9f107ce3ae311ed365e83d66dbd to your computer and use it in GitHub Desktop.
H4 projection of the 600-cell polytope
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # https://vixra.org/pdf/1411.0130v1.pdf | |
| # vertices of the 600-cell | |
| phi <- (1+sqrt(5))/2 | |
| vs <- rbind( | |
| c( -1.0 , -1.0 , -1.0 , -1.0 ) | |
| , c( -1.0 , -1.0 , -1.0 , 1.0 ) | |
| , c( -1.0 , -1.0 , 1.0 , -1.0 ) | |
| , c( -1.0 , -1.0 , 1.0 , 1.0 ) | |
| , c( -1.0 , 1.0 , -1.0 , -1.0 ) | |
| , c( -1.0 , 1.0 , -1.0 , 1.0 ) | |
| , c( -1.0 , 1.0 , 1.0 , -1.0 ) | |
| , c( -1.0 , 1.0 , 1.0 , 1.0 ) | |
| , c( 1.0 , -1.0 , -1.0 , -1.0 ) | |
| , c( 1.0 , -1.0 , -1.0 , 1.0 ) | |
| , c( 1.0 , -1.0 , 1.0 , -1.0 ) | |
| , c( 1.0 , -1.0 , 1.0 , 1.0 ) | |
| , c( 1.0 , 1.0 , -1.0 , -1.0 ) | |
| , c( 1.0 , 1.0 , -1.0 , 1.0 ) | |
| , c( 1.0 , 1.0 , 1.0 , -1.0 ) | |
| , c( 1.0 , 1.0 , 1.0 , 1.0 ) | |
| , c( 0.0 , 0.0 , 0.0 , -2.0 ) | |
| , c( 0.0 , 0.0 , 0.0 , 2.0 ) | |
| , c( 0.0 , 0.0 , -2.0 , 0.0 ) | |
| , c( 0.0 , 0.0 , 2.0 , 0.0 ) | |
| , c( 0.0 , -2.0 , 0.0 , 0.0 ) | |
| , c( 0.0 , 2.0 , 0.0 , 0.0 ) | |
| , c( -2.0 , 0.0 , 0.0 , 0.0 ) | |
| , c( 2.0 , 0.0 , 0.0 , 0.0 ) | |
| , c( -phi , -1.0 , -1/phi , 0.0 ) | |
| , c( -phi , -1.0 , 1/phi , 0.0 ) | |
| , c( -phi , 1.0 , -1/phi , 0.0 ) | |
| , c( -phi , 1.0 , 1/phi , 0.0 ) | |
| , c( phi , -1.0 , -1/phi , 0.0 ) | |
| , c( phi , -1.0 , 1/phi , 0.0 ) | |
| , c( phi , 1.0 , -1/phi , 0.0 ) | |
| , c( phi , 1.0 , 1/phi , 0.0 ) | |
| , c( -phi , -1/phi , 0.0 , -1.0 ) | |
| , c( -phi , 1/phi , 0.0 , -1.0 ) | |
| , c( -phi , -1/phi , 0.0 , 1.0 ) | |
| , c( -phi , 1/phi , 0.0 , 1.0 ) | |
| , c( phi , -1/phi , 0.0 , -1.0 ) | |
| , c( phi , 1/phi , 0.0 , -1.0 ) | |
| , c( phi , -1/phi , 0.0 , 1.0 ) | |
| , c( phi , 1/phi , 0.0 , 1.0 ) | |
| , c( -phi , 0.0 , -1.0 , -1/phi ) | |
| , c( -phi , 0.0 , -1.0 , 1/phi ) | |
| , c( -phi , 0.0 , 1.0 , -1/phi ) | |
| , c( -phi , 0.0 , 1.0 , 1/phi ) | |
| , c( phi , 0.0 , -1.0 , -1/phi ) | |
| , c( phi , 0.0 , -1.0 , 1/phi ) | |
| , c( phi , 0.0 , 1.0 , -1/phi ) | |
| , c( phi , 0.0 , 1.0 , 1/phi ) | |
| , c( -1.0 , -phi , 0.0 , -1/phi ) | |
| , c( -1.0 , -phi , 0.0 , 1/phi ) | |
| , c( 1.0 , -phi , 0.0 , -1/phi ) | |
| , c( 1.0 , -phi , 0.0 , 1/phi ) | |
| , c( -1.0 , phi , 0.0 , -1/phi ) | |
| , c( -1.0 , phi , 0.0 , 1/phi ) | |
| , c( 1.0 , phi , 0.0 , -1/phi ) | |
| , c( 1.0 , phi , 0.0 , 1/phi ) | |
| , c( -1.0 , -1/phi , -phi , 0.0 ) | |
| , c( -1.0 , 1/phi , -phi , 0.0 ) | |
| , c( 1.0 , -1/phi , -phi , 0.0 ) | |
| , c( 1.0 , 1/phi , -phi , 0.0 ) | |
| , c( -1.0 , -1/phi , phi , 0.0 ) | |
| , c( -1.0 , 1/phi , phi , 0.0 ) | |
| , c( 1.0 , -1/phi , phi , 0.0 ) | |
| , c( 1.0 , 1/phi , phi , 0.0 ) | |
| , c( -1.0 , 0.0 , -1/phi , -phi ) | |
| , c( -1.0 , 0.0 , 1/phi , -phi ) | |
| , c( 1.0 , 0.0 , -1/phi , -phi ) | |
| , c( 1.0 , 0.0 , 1/phi , -phi ) | |
| , c( -1.0 , 0.0 , -1/phi , phi ) | |
| , c( -1.0 , 0.0 , 1/phi , phi ) | |
| , c( 1.0 , 0.0 , -1/phi , phi ) | |
| , c( 1.0 , 0.0 , 1/phi , phi ) | |
| , c( -1/phi , -phi , -1.0 , 0.0 ) | |
| , c( 1/phi , -phi , -1.0 , 0.0 ) | |
| , c( -1/phi , -phi , 1.0 , 0.0 ) | |
| , c( 1/phi , -phi , 1.0 , 0.0 ) | |
| , c( -1/phi , phi , -1.0 , 0.0 ) | |
| , c( 1/phi , phi , -1.0 , 0.0 ) | |
| , c( -1/phi , phi , 1.0 , 0.0 ) | |
| , c( 1/phi , phi , 1.0 , 0.0 ) | |
| , c( -1/phi , -1.0 , 0.0 , -phi ) | |
| , c( 1/phi , -1.0 , 0.0 , -phi ) | |
| , c( -1/phi , 1.0 , 0.0 , -phi ) | |
| , c( 1/phi , 1.0 , 0.0 , -phi ) | |
| , c( -1/phi , -1.0 , 0.0 , phi ) | |
| , c( 1/phi , -1.0 , 0.0 , phi ) | |
| , c( -1/phi , 1.0 , 0.0 , phi ) | |
| , c( 1/phi , 1.0 , 0.0 , phi ) | |
| , c( -1/phi , 0.0 , -phi , -1.0 ) | |
| , c( 1/phi , 0.0 , -phi , -1.0 ) | |
| , c( -1/phi , 0.0 , -phi , 1.0 ) | |
| , c( 1/phi , 0.0 , -phi , 1.0 ) | |
| , c( -1/phi , 0.0 , phi , -1.0 ) | |
| , c( 1/phi , 0.0 , phi , -1.0 ) | |
| , c( -1/phi , 0.0 , phi , 1.0 ) | |
| , c( 1/phi , 0.0 , phi , 1.0 ) | |
| , c( 0.0 , -phi , -1/phi , -1.0 ) | |
| , c( 0.0 , -phi , 1/phi , -1.0 ) | |
| , c( 0.0 , -phi , -1/phi , 1.0 ) | |
| , c( 0.0 , -phi , 1/phi , 1.0 ) | |
| , c( 0.0 , phi , -1/phi , -1.0 ) | |
| , c( 0.0 , phi , 1/phi , -1.0 ) | |
| , c( 0.0 , phi , -1/phi , 1.0 ) | |
| , c( 0.0 , phi , 1/phi , 1.0 ) | |
| , c( 0.0 , -1.0 , -phi , -1/phi ) | |
| , c( 0.0 , -1.0 , -phi , 1/phi ) | |
| , c( 0.0 , 1.0 , -phi , -1/phi ) | |
| , c( 0.0 , 1.0 , -phi , 1/phi ) | |
| , c( 0.0 , -1.0 , phi , -1/phi ) | |
| , c( 0.0 , -1.0 , phi , 1/phi ) | |
| , c( 0.0 , 1.0 , phi , -1/phi ) | |
| , c( 0.0 , 1.0 , phi , 1/phi ) | |
| , c( 0.0 , -1/phi , -1.0 , -phi ) | |
| , c( 0.0 , 1/phi , -1.0 , -phi ) | |
| , c( 0.0 , -1/phi , 1.0 , -phi ) | |
| , c( 0.0 , 1/phi , 1.0 , -phi ) | |
| , c( 0.0 , -1/phi , -1.0 , phi ) | |
| , c( 0.0 , 1/phi , -1.0 , phi ) | |
| , c( 0.0 , -1/phi , 1.0 , phi ) | |
| , c( 0.0 , 1/phi , 1.0 , phi ) | |
| ) | |
| # we need the edges | |
| library(cxhull) | |
| hull <- cxhull(vs, triangulate = FALSE) | |
| edges <- hull$edges | |
| # --- Step two: H4 projection --- | |
| u1 <- c(0, (1+sqrt(5))*sin(pi/30), 0, 1) | |
| u2 <- c((1+sqrt(5))*sin(pi/15), 0, 2*sin(2*pi/15), 0) | |
| u1 <- u1 / sqrt(c(crossprod(u1))) | |
| u2 <- u2 / sqrt(c(crossprod(u2))) | |
| # projections on the plane | |
| proj <- function(v){ | |
| c(c(crossprod(v, u1)), c(crossprod(v, u2))) | |
| } | |
| points <- t(apply(vs, 1L, proj)) | |
| norms2 <- round(apply(points, 1L, crossprod), 1L) | |
| table(norms2) | |
| # 0.4 1.6 2.4 3.6 | |
| # 30 30 30 30 | |
| # save plot as SVG | |
| colors <- viridisLite::turbo(10L, direction = -1) | |
| svg(filename = "H4_600-cell.svg", onefile = TRUE) | |
| opar <- par(mar = c(0, 0, 0, 0)) | |
| plot( | |
| points[!duplicated(points), ], pch = 19, cex = 0.3, asp = 1, | |
| axes = FALSE, xlab = NA, ylab = NA | |
| ) | |
| for(i in 1L:nrow(edges)){ | |
| twopoints <- points[edges[i, ], ] | |
| nrms2 <- round(sort(apply(twopoints, 1L, crossprod)), 1L) | |
| nrms21 <- nrms2[1L] | |
| nrms22 <- nrms2[2L] | |
| if(nrms21 == 3.6){ | |
| col <- 1L | |
| }else if(nrms21 == 2.4){ | |
| col <- ifelse(nrms22 == 2.4, 2L, 3L) | |
| }else if(nrms21 == 1.6){ | |
| col <- ifelse(nrms22 == 1.6, 4L, ifelse(nrms22 == 2.4, 5L, 6L)) | |
| }else if(nrms21 == 0.4){ | |
| col <- ifelse(nrms22 == 0.4, 7L, | |
| ifelse(nrms22 == 1.6, 8L, | |
| ifelse(nrms22 == 2.4, 9L, 10L))) | |
| } | |
| lines( | |
| twopoints, lwd = 0.5, col = colorspace::darken(colors[col], amount = 0.5) | |
| ) | |
| } | |
| par(opar) | |
| dev.off() | |
| # convert to PNG | |
| rsvg::rsvg_png("H4_600-cell.svg", file = "H4_600-cell.png") | |
| # let's plot an hyperbolic version #### | |
| library(gyro) | |
| colors <- rainbow(10L) | |
| # save plot as SVG | |
| svg(filename = "H4_600-cell_hyperbolic.svg", onefile = TRUE) | |
| opar <- par(mar = c(0, 0, 0, 0)) | |
| plot( | |
| points[!duplicated(points), ], pch = 19, cex = 0.3, asp = 1, | |
| axes = FALSE, xlab = NA, ylab = NA | |
| ) | |
| for(i in 1L:nrow(edges)){ | |
| twopoints <- points[edges[i, ], ] | |
| nrms2 <- round(sort(apply(twopoints, 1L, crossprod)), 1L) | |
| nrms21 <- nrms2[1L] | |
| nrms22 <- nrms2[2L] | |
| if(nrms21 == 3.6){ | |
| col <- 1L | |
| }else if(nrms21 == 2.4){ | |
| col <- ifelse(nrms22 == 2.4, 2L, 3L) | |
| }else if(nrms21 == 1.6){ | |
| col <- ifelse(nrms22 == 1.6, 4L, ifelse(nrms22 == 2.4, 5L, 6L)) | |
| }else if(nrms21 == 0.4){ | |
| col <- ifelse(nrms22 == 0.4, 7L, | |
| ifelse(nrms22 == 1.6, 8L, | |
| ifelse(nrms22 == 2.4, 9L, 10L))) | |
| } | |
| AB <- gyrosegment(twopoints[1L, ], twopoints[2L, ], s = 0.8) | |
| lines( | |
| AB, lwd = 0.5, col = colorspace::darken(colors[col], amount = 0.15) | |
| ) | |
| } | |
| par(opar) | |
| dev.off() | |
| # convert to PNG | |
| rsvg::rsvg_png( | |
| "H4_600-cell_hyperbolic.svg", file = "H4_600-cell_hyperbolic.png" | |
| ) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment