Skip to content

Instantly share code, notes, and snippets.

@Mozk0

Mozk0/gist:394988

Created May 9, 2010 06:49
Show Gist options
  • Save Mozk0/394988 to your computer and use it in GitHub Desktop.
Save Mozk0/394988 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.r
require(fork)
require(gtools)
#
# socket listen
# ゾンビをたくさんつくります。
server.start <- function(port = 3333) {
server.pid <<-
fork(function() {
repeat{
s <- make.socket("localhost", port, server = TRUE)
fork(function() process.connection(s))
close.socket(s)
}
})
return(server.pid)
}
server.restart <- function(port = 3333) {
server.stop()
server.start(port)
}
server.stop <- function(pid = server.pid) {
kill(pid)
}
#
# リクエストをパース・レスポンスを呼び出し
#
process.connection <- function(socket) {
set.seed(as.integer(Sys.time()))
on.exit(close.socket(socket))
on.exit(exit(), add = TRUE)
request <- message.parse(read.socket(socket, maxlen=1024))
method <- get.method(request)
URI <- get.URI(request)
res <- if (method == "GET" && not.favicon(URI)) {
get.response(request)
} else if (method == "GET") {
not.found.response(request)
} else if (method == "HEAD") {
head.response(request)
} else {
not.implemented.response(request)
}
if(is.png(URI)) {
write.vector.socket.raw(socket, res)
} else {
write.vector.socket(socket, res)
}
}
#
# レスポンス
#
head.response <- function(request) {
c("HTTP/1.0 200 OK\r\n",
"Connection: close\r\n",
if (is.png(get.URI(request))) {
"Content-type: image/png\r\n"
} else {
"Content-type: text/html\r\n"
},
"\r\n")
}
get.response <- function(request) {
URI <- get.URI(request)
filename <- substr(URI, 2, nchar(URI))
if (URI == "/") {
res <- p1()
c(head.response(request), get.header(request), res, get.footer(request))
} else if (is.suffix("png", URI)) {
file.to.string(filename)
} else {
fun <- match.fun(filename)
res <- fun()
c(head.response(request), get.header(request), res, get.footer(request))
}
}
get.header <- function(request) {
"<html>
<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">
<body>"
}
get.footer <- function(request) {
"</body>
</html>"
}
not.implemented.response <- function(request) {
c("HTTP/1.0 501 NOT IMPLEMENTED\r\n",
"\r\n")
}
not.found.response <- function(request) {
c("HTTP/1.0 404 NOT FOUND\r\n",
"\r\n")
}
#
# parser
#
message.parse <- function(msg) {
print(msg)
msg.split <- strsplit(msg[1], "\r\n")[[1]]
request.line <- msg.split[1]
request.line.split <- strsplit(request.line, " ")[[1]]
method <- request.line.split[1]
URI <- request.line.split[2]
c(method, URI)
}
get.method <- function(r) r[[1]] #accessors
get.URI <- function(r) r[[2]]
#
# socket に送るための関数たち
#
# pngを読みだして文字列に
file.to.string <- function(filename) {
fp <- file(filename, "rb")
res <- readBin(fp, "raw", n = 32768)
a <- readBin(fp, "raw", n = 32768)
while (length(a) != 0) {
res <- c(res, a)
a <- readBin(fp, "raw", n = 32768)
}
rawToChar(res, TRUE)
}
write.vector.socket <- function(socket, res) {
if (length(port <- as.integer(socket$socket)) != 1L)
stop("invalid 'socket' argument")
sapply(res,
function(x) {
strlen <- as.integer(length(charToRaw(x)))
invisible(.C("Rsockwrite", port, x, as.integer(0L),
strlen, strlen, PACKAGE = "base"))
})
}
#png用
write.vector.socket.raw <- function(socket, res) {
if (length(port <- as.integer(socket$socket)) != 1L)
stop("invalid 'socket' argument")
sapply(res,
function(x) {
strlen <- as.integer(max(1L, length(strsplit(x, "")[[1]]))) #ナル文字用
invisible(.C("Rsockwrite", port, x, as.integer(0L),
strlen, strlen, PACKAGE = "base"))
})
}
is.suffix <- function(suffix, str) {
!(length(grep(paste(suffix, "$", sep = ""), str)) == 0)
}
not.favicon <- function(URI) {
!is.suffix("ico", URI)
}
is.png <- function(URI) {
is.suffix("png", URI)
}
#
# gensym
#
gensym.maker <- function(i) {
function(e = environment()) {
repeat {
i <<- i + 1
symbol <- paste("g", i, sep = "")
if (!exists(symbol, e))
return(as.name(symbol))
}
}
}
gensym <- gensym.maker(0)
rm(gensym.maker)
dq <- "\""
#
# HTML
#
h1 <- function(str){
tag("h1", str)
}
h2 <- function(str){
tag("h3", str)
}
a <- function(href){
tag("a", href, option = c("href=" , dq, href, dq))
}
pre <- function(str){
tag("pre", gsub(">", "&gt;", gsub("<", "&lt;", str)))
}
img <- function(src){
single.tag("img", c("src=", dq, src, dq))
}
single.tag <- function(tag, option = ""){
c("<", tag, " ", option, ">")
}
br <- single.tag("br")
hr <- single.tag("hr")
cmd.env <- new.env(parent = .GlobalEnv)
cmd.img.env <- new.env(parent = cmd.env)
cmd <- function(exp) {
result <- capture.output(eval(substitute(exp), envir = cmd.env))
output <- Reduce(function(a,b) {
paste(a, b, sep = "\n")
},
result)
input <- Reduce(function(a,b) {
paste(a, b, sep = "\n")
},
capture.output(substitute(exp)))
c(left(pre(input)), left(blue(pre(output))))
}
cmd.silent <- function(exp) {
eval(substitute(exp), envir = cmd.env)
""
}
cmd.img <- function(exp, filename) {
filename <- paste(filename, ".png", sep="")
png(filename)
eval(substitute(exp), cmd.img.env)
dev.off()
c(pre(capture.output(substitute(exp))),
img(filename), br)
}
tag <- function(tag, content, option = ""){
c("<", tag, " ", option, ">", content, "</", tag, ">")
}
center <- function(str){
tag("div", str, option="align=\"center\"")
}
left <- function(str){
tag("div", str, option="align=\"left\"")
}
blue <- function(str){
tag("font", str, option="color=\"#4169E1\"")
}
p <- function(...){
content <- Reduce(c, Map(h1, list(...)))
function(){center(content)}
}
n <- function(...){
content <- Reduce(c, Map(h1, list(...)))
function(){content}
}
m <- function(...){
content <- Reduce(c, Map(h2, list(...)))
function(){content}
}
small <- function(...){
content <- Reduce(c, Map(h2, list(...)))
function(){center(content)}
}
get.name <- function(i){
paste("page", as.character(i), sep="")
}
#
# Content
#
d <- function(f){
function() (f())()
}
page <- defmacro(DOTS, expr=d(function() p(...)))
robots.txt <- p("")
p1 <- page(a("p02"),
cmd.img(hist(rnorm(20)), "rnorm20"),
cmd(summary(rnorm(10))))
p02 <- page(a("p20"),
"タイトル",
"environment")
p20 <- page(a("p21"),
"自己紹介",
"もずく",
"http://twitter.com/Mozk_",
"学生 - 生物情報科学科")
p21 <- page(a("p36"),
"タイトル改め",
"environmentとマクロもどき")
p36 <- page(a("p37"),
"第一章 環境")
p37 <- page(a("p38"),
"環境は",
"「変数名と値の対応」と",
"「親の環境]")
p38 <- page(a("p39"),
"環境は",
"「変数名と値の対応」と",
"「親の環境]",
hr,
"Rの式はつねに何かの環境の下で評価される",
"（子の環境=>親の環境の順で変数を探していく）")
p39 <- page(a("p40"),
"実演")
p40 <- page(a("p42"),
"現在地の環境をとってくる",
cmd(environment()))
p42 <- page(a("p43"),
"functionに結びついた環境を",
"とってくることもできる",
cmd(hoge <- function(a,b) a + b),
cmd(environment(hoge)))
p43 <- page(a("p44"),
"evalq : 指定した環境でRの式を評価",
cmd.silent(f <- function(i) { function() i }),
left(pre("f <- function(i) { function() i }")),
cmd(g <- f(3)),
cmd(g()),
cmd(evalq(i <- 2, envir = environment(g))),
cmd(g()))
p44 <- page(a("p46"),
"値の取得・代入専用の関数もある",
cmd(a <- 0),
cmd(get("a", envir = environment())),
cmd(assign("a", 1, envir = environment())),
cmd(a))
p46 <- small(a("p50"),
"環境を扱うための関数が揃っている",
cmd.silent(f <- function(){}),
cmd.silent(i <- 2),
cmd.silent(x <- 3),
cmd(ls(environment(f))),
cmd(exists("x", environment(f))),
"環境を代入・環境への代入・環境の生成もできる",
cmd(f <- function() i),
cmd(e <- new.env()),
cmd(evalq(i <- 3, e)),
cmd(environment(f) <- e))
p50 <- page(a("p60"),
"関数を実行すると",
"仮引数と実引数の対応を持つ環境が生成",
hr,
"関数の中身は",
"その新しい環境下で評価される")
f <- function(i) function(){}
p60 <- page(a("p72"),
cmd.silent(f <- function(i){function(){} }),
left(pre("f <- function(i){function(){} }")),
cmd.silent({g0 <- f(0); g1 <- f(1)}),
left(pre("g0 <- f(0); g1 <- f(1)")),
hr,
"仮引数と実引数の対応",
cmd(evalq(i, environment(g0))),
cmd(evalq(i, environment(g1))))
p72 <- page(a("p73"),
"「関数の中身の環境」の親の環境",
"は",
"関数生成時の環境",
"(function() ...文が評価された環境)")
p73 <- small(a("p80"),
cmd(make.counter <- function(i){function(){ i <<- i + 1; return(i) }}),
cmd(c1 <- make.counter(10)),
cmd(c2 <- make.counter(20)),
cmd(i <- 300),
cmd(c1()),cmd(c1()),cmd(c2()))
p80 <- page(a("p87"),
"parent.env : 親の環境を習得",
cmd(f <- function(){ environment() }),
cmd(list(parent.env(f()), environment(f))),
"完全に一致")
p87 <- page(a("p88"),
"Rは基本的に静的スコープ",
hr,
left(pre("fが見に行くのは↓のi")),
cmd(i <- 0),
cmd(f <- function() i),
cmd(g <- function(i){ f()}),
cmd(g(1)),
hr,
pre("親の環境をたどっていくので"),
pre("関数呼び出し元の環境は関係ない"))
p88 <- page(a("p85"),
"動的スコープもどき",
cmd(i <- 0),
cmd(f <- function() evalq(i, parent.frame())),
cmd(g <- function(i){ f() }),
left(pre("fが見に行くのは↑のi")),
cmd(g(1)))
p85 <- page(a("p135"),
"parent.frame : 関数呼び出し元の環境を取得",
cmd(f <- function(){ parent.frame() }),
cmd(list(f(), environment(f))))
p135 <- page(a("p140"),
"...")
p140 <- page(a("p150"),
"環境だけじゃなくて")
p150 <- page(a("p153"),
"環境だけじゃなくて",
"式を扱うための関数も揃っている!!")
p153 <- page(a("p155"),
"第1.5章 式")
p155 <- page(a("p350"),
"式を取得",
cmd(((exp = quote(x + y)))),
hr,
"式に代入",
cmd(exp[[1]] <- quote(`*`)),
cmd(exp))
p350 <- page(a("p360"),
"substitute",
"仮引数に渡された式そのものを取得したい")
p360 <- small(a("p370"),
cmd(ラベルに着目 <- rnorm(1000)),
cmd.img(hist(ラベルに着目), "labelni"))
p370 <- small(a("p395"),
"例",
cmd(substitute(x * y, list(x = quote(a + b)))),
"式の構造の置き換え",
"cppのような文字列の置き換えではない",
hr,
"第一引数の式の中に出てくるシンボル（の大部分）を",
"第二引数のルールに従って置き換える")
p395 <- page(a("p400"),
"第二引数のデフォルト引数は",
"仮引数","と","「その仮引数に渡された式」","のリスト",
"(と考えてよい)")
p400 <- small(a("p601"),
cmd(f <- function(a,b){substitute(a + b)}),
cmd(f(2 + 2, x * y)),
hr,
pre("substitute(a + b, list( a = quote(2 + 2), b = quote(x * y)))"),
"のようになる。")
p601 <- small(a("p330"),
"余談",
"式オブジェクトそのものをsubstituteしたい時は",
"evalとsubstituteを組み合わせる。",
cmd(exp <- quote(hoge + 2)),
cmd(eval(substitute(substitute(e, list(hoge = 3)), list(e = exp)))),
hr,
"説明",
cmd(substitute(e, list(e = exp))),
cmd(substitute(substitute(e, list(hoge = 3)), list(e = exp))),
hr,
"これはだめ",
cmd(substitute(exp, list(hoge = 3))),
hr,
"Lispのバッククオートリーダマクロの入れ子と似ている",
"S-PLUSでは動作が違うらしい。")
p330 <- page(a("p340"),
"eval",
"式を評価したい")
p340 <- page(a("p414"),
cmd(e <- new.env()),
cmd(assign("x", 2, e)),
cmd(eval(quote(x + 3), envir = e)),
cmd(evalq(x + 3, envir = e)),
"評価する環境を指定できる")
p414 <- page(a("p415"),
"第二章 マクロ",
"#define swap(a, b) {tmp <- a; a <- b; b <- tmp}",
"のようなもの",
"ただし置き換えではなくチューリング完全な操作をしたい")
p415 <- page(a("p416"),
"アイデア：",
"式をテンプレートにsubstituteして",
"parent.frameでevalする")
p416 <- small(a("p417"),
"簡易マクロ",
cmd.silent(swap <- function(a,b){ eval(substitute({tmp <- a; a <- b; b <- tmp}), parent.frame()) }),
left(pre(
"swap <- function(a,b){
eval(substitute({tmp <- a; a <- b; b <- tmp}),
envir = parent.frame())
}")),
cmd(a <- 1:2),
cmd(swap(a[1], a[2])),
cmd(a[1]),
cmd(a[2]))
p417 <- page(a("p418"),
"しかし",
cmd.silent(swap <- function(a,b){ eval(substitute({tmp <- a; a <- b; b <- tmp}), parent.frame()) }),
cmd(tmp <- 0),
cmd(i <- 1),
cmd(swap(tmp, i)),
cmd(tmp),
cmd(i))
p418 <- page(a("p419"),
"変数の衝突",
left(pre("tmp <- tmp")),
left(pre("tmp <- i")),
left(pre("i <- tmp")))
p419 <- page(a("p300"),
"使われていない変数を用意する必要がある",
hr,
"もっと高機能にしたい")
p300 <- page(center(a("p421")),
"gensymで使われていない変数名を生成",
left(pre(
"repeat {
i &lt;&lt;- i + 1
symbol &lt;- paste(\"g\", i, sep = \"\")
if (!exists(symbol, envir = e))
return(as.name(symbol))
}")),
hr,
center("iを増やしていってsymbolを次々に生成"),
center("existsで使われているかを判定"))
p421 <- page(a("p440"),
"ちょっと高機能マクロ",
left(pre("マクロ実引数 <- substitute(マクロ仮引数)")),
left(pre(
"展開式 <- substitute(テンプレート,
list(仮 = マクロ実引数)),
他 = 他の式A))")),
"テンプレートにマクロ実引数をあてはめる",
"衝突しない変数もあてはめる")
p440 <- p(a("p450"),
cmd.silent(swap <- function(マクロ仮引数a, マクロ仮引数b) {
マクロ実引数a = substitute(マクロ仮引数a)
マクロ実引数b = substitute(マクロ仮引数b)
他の式t = gensym(parent.frame())
展開式 <- substitute({tmp <- a ; a <- b; b <- tmp},
list(a = マクロ実引数a,
b = マクロ実引数b,
tmp = 他の式t))
eval(展開式, envir = parent.frame())
}),
left(pre(
"swap <- function(仮a, 仮b) {
実a = substitute(仮a)
実b = substitute(仮b)
他t = gensym(parent.frame())
展開式 <- substitute({tmp <- a ; a <- b; b <- tmp},
list(a = 実a,
b = 実b,
tmp = 他t))
eval(展開式, envir = parent.frame())}")),
cmd(tmp <- 0),
cmd(i <- 1),
cmd(swap(tmp, i)),
cmd(tmp),
cmd(i))
p450 <- p("終わり",
"ありがとうございました")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment