- 昨日球面と球面の直積としてエキゾチックな球面ということを書いた
- 球面と球面の直積っていうのは、「普通の多次元球」を描いて、その球面上の点の上に別の次元を使った球面を描くような感じ
- これを上半、下半に分けるというのは、こんな感じにすることで
- 張り合わせをねじる、そのまま貼るか、ひねって貼るか、というのが昨日の話題で、「ひねって貼る」には、一対一対応をとらないと行けなくて、それが「素直なひねり」になっているとよいね、という話だった。そういう意味で、球面版のメビウスの輪、的な話
rsphere <- function(n,d,r,m=rep(0,d)){
X <- matrix(rnorm(n*d),ncol=d)
X <- (X)/sqrt(apply(X^2,1,sum))*r
t(t(X)+m)
}
d1 <-3
d2 <- 2
r1 <- 1
r2 <- 0.5
n.pt1 <- 10000
X1 <- rsphere(n.pt1,d1,r1)
plot3d(X1)
s <- 1:10
n.pt2 <- 1000
X2 <- rsphere(n.pt2,d2,r2)
X2on1 <- matrix(0,0,d1)
for(i in 1:length(s)){
tmp <- t(t(X2)+X1[s[i],1:d2])
tmp <- cbind(tmp,rep(X1[i,3],n.pt2))
X2on1 <- rbind(X2on1, tmp)
}
XX <- rbind(X1,X2on1)
XX <- rbind(XX,rep(max(XX),d1))
XX <- rbind(XX,rep(min(XX),d1))
plot3d(XX,col=c(rep(1,n.pt1),rep(2,length(X2on1[,1])),rep(0,2)))
d1 <-2
d2 <- 2
r1 <- 1
r2 <- 0.5
n.pt1 <- 1000
X1 <- rsphere(n.pt1,d1,r1)
s <- 1:100
n.pt2 <- 1000
X2 <- rsphere(n.pt2,d2,r2)
X2on1 <- matrix(0,0,3)
for(i in 1:length(s)){
tmp.x1 <- X1[s[i],1] + X2[,1] * X1[s[i],1]/r1
tmp.x2 <- X1[s[i],2] + X2[,1] * X1[s[i],2]/r1
tmp.x3 <- X2[,2]
X2on1 <- rbind(X2on1, cbind(tmp.x1,tmp.x2,tmp.x3))
}
X2on1 <- rbind(X2on1,rep(max(X2on1),3))
X2on1 <- rbind(X2on1,rep(min(X2on1),3))
plot3d(X2on1)
d1 <-2
d2 <- 2
r1 <- 1
r2 <- 0.5
n.pt1 <- 1000
X1 <- rsphere(n.pt1,d1,r1)
s <- 1:100
n.pt2 <- 1000
X2 <- rsphere(n.pt2,d2,r2)
X2on1 <- matrix(0,0,3)
ue.shita <- rep(0,length(n.pt2))
delta <- 0.1
for(i in 1:length(s)){
if(X1[s[i],2] > 0){
tmp.x1 <- X1[s[i],1] + X2[,1] * X1[s[i],1]/r1
tmp.x2 <- X1[s[i],2] + X2[,1] * X1[s[i],2]/r1 + delta
tmp.x3 <- X2[,2]
ue.shita[i] <- 2
}else{
tmp.x1 <- X1[s[i],1] + X2[,1] * X1[s[i],1]/r1
tmp.x2 <- X1[s[i],2] + X2[,1] * X1[s[i],2]/r1
tmp.x3 <- X2[,2]
ue.shita[i] <- 3
}
X2on1 <- rbind(X2on1, cbind(tmp.x1,tmp.x2,tmp.x3))
}
X2on1 <- rbind(X2on1,rep(max(X2on1),3))
X2on1 <- rbind(X2on1,rep(min(X2on1),3))
plot3d(X2on1,col=c(rep(c(ue.shita),each=n.pt),rep(1,2)))