ヒルベルト曲線

Rのlibrary(grid)でタートルグラフィックスのその2。やはりフラクタル曲線として有名なヒルベルト曲線を描いてみた。



アルゴリズムは、en.wikipediaのHilbert_curveを参考にした。コードは「続きを読む」の下。


turtle.R

##
## turtle graphics
##

# use gird
library(grid)

turtle.init <- function(vp = viewport(0.5, 0.5,
                                      width=1, height=1,
                                      xscale=c(-1, 1), yscale=c(-1, 1)),
                        col = "black", loc = c(0, 0), angle = 0,
                        lwd = 1, pen = TRUE) {
	grid.newpage()
	pushViewport(vp)
	grid.move.to(0, 0, default.units = "native")

	# environment to keep parameters
	turtle <- new.env()
	assign("col", col, envir = turtle)
	assign("loc", loc, envir = turtle)
	assign("angle", angle, envir = turtle)
	assign("pen", TRUE, envir = turtle)

	# return the environment
	turtle
}

pen.up <- function(turtle) {
	if (is.environment(turtle)) {
		assign("pen", FALSE, envir = turtle)
	} else {
		stop("The first argument must be an environment.")
	}
}

pen.down <- function(turtle) {
	if (is.environment(turtle)) {
		assign("pen", TRUE, envir = turtle)
	} else {
		stop("The argument must be an environment.")
	}
}

set.color <- function(turtle, col) {
	if (is.environment(turtle)) {
		assign("col", col, envir = turtle)
	} else {
		stop("The first argument must be an environment.")
	}
}

set.angle <- function(turtle, angle = 0) {
	if (is.environment(turtle)) {
		assign("angle", angle, envir = turtle)
	} else {
		stop("The first argument must be an environment.")
	}
}

set.lwd <- function(turtle, lwd = 1) {
	if (is.environment(turtle)) {
		assign("lwd", lwd, envir = turtle)
	} else {
		stop("The first argument must be an environment.")
	}
}

set.location <- function(turtle, loc = c(0, 0)) {
	if (is.environment(turtle)) {
		assign("loc", loc, envir = turtle)
		grid.move.to(loc[1], loc[2], default.units = "native")
	} else {
		stop("The first argument must be an environment.")
	}
}
	
forward <- function(turtle, length) {
	if (is.environment(turtle)) {
		loc <- get("loc", envir = turtle)
		pen <- get("pen", envir = turtle)
		col <- get("col", envir = turtle)
		lwd <- get("lwd", envir = turtle)
		x <- loc[1] + length * cos(turtle$angle * pi / 180)
		y <- loc[2] + length * sin(turtle$angle * pi / 180)
		if (pen)
			grid.line.to(x, y,
			             gp = gpar(col = col, lwd = lwd),
			             default.units = "native")
		else
			grid.move.to(x, y,
			             default.units = "native")
		assign("loc", c(x, y), envir = turtle)
	} else {
		stop("The first argument must be an environment.")
	}
}

backword <- function(turtle, length) {
	forward(turtle, -length)
}

left <- function(turtle, angle) {
	if (is.environment(turtle)) {
		t.angle <- get("angle", envir = turtle)
		assign("angle", t.angle + angle, envir = turtle)
	} else {
		stop("The first argument must be an environment.")		
	}
}

right <- function(turtle, angle) {
	left(turtle, -angle)
}

Hilbert.R

source("turtle.R")

l <- function(turtle, level, length) {
	if (level > 0) {
		left(turtle, 90)
		r(turtle, level - 1, length)
		forward(turtle, length)
		right(turtle, 90)
		l(turtle, level - 1, length)
		forward(turtle, length)
		l(turtle, level - 1, length)
		right(turtle, 90)
		forward(turtle, length)
		r(turtle, level - 1, length)
		left(turtle, 90)
	}
}

r <- function(turtle, level, length) {
	if (level > 0) {
		right(turtle, 90)
		l(turtle, level - 1, length)
		forward(turtle, length)
		left(turtle, 90)
		r(turtle, level - 1, length)
		forward(turtle, length)
		r(turtle, level - 1, length)
		left(turtle, 90)
		forward(turtle, length)
		l(turtle, level - 1, length)
		right(turtle, 90)
	}
}

t <- turtle.init()
set.location(t, c(-0.9, -0.9))
set.angle(t, 0)
set.color(t, "red")
level <- 6
length <- 1.8 / (2^level - 1)
l(t, level, length)

タグ：R library(grid)

コメント 2

思ったよりもプログラムが長いものなのですね。
by 春分 (2008-09-03 21:59) 

前半のタートルグラフィックス部分には、今回のヒルベルト曲線には使わないコードも含まれていたりしますので。
by hiroki (2008-09-04 05:34)