Monads on R

monad.R

"%<-%" <- function(x,y) call("<-",substitute(x),substitute(y))
returm <- function(x) call("return",substitute(x))
exec <- quote

join <- function(ss,sep) {
  res <- ""
  for (s in ss) {
    res <- paste(res,s,sep=sep)
  }
  res
}

monad <- function(bind, ret) {

  list2call <- function(calls) {
    t <- call("{")
    for (x in calls) t[[length(t)+1]] <- x
    return(t)
  }

  newfunc <- function(a,b) {
    f <- eval(parse(text=paste("function(",a,"){}",sep="")))
    body(f) <- if (is.list(b)) list2call(b) else b
    return(f)
  }

  function(...) {
    ss <- list(...)
    f <- (function(i,a,b) {
      if (i>length(ss)) return(newfunc(a,b))
      s <- ss[[i]]
      if (s[[1]] == "<-") {
        r <- Recall(i+1,s[[2]],list())
        newfunc(a,append(b,call("bind",s[[3]],r)))
      } else if (s[[1]] == "return") {
        Recall(i+1,a,append(b,call("ret",s[[2]])))
      }
    })(1,"",list())

    params <- append(as.list(parent.frame()),list(bind=bind,ret=ret))
    f <- evalq(eval(parse(text=join(deparse(f),""))),params)
    f()
  }
}

## Maybeモナド

maybe_do <- monad(
  bind = function(x,f) if(is.na(x)) NA else f(x),
  ret = function(x) x
)

maybe_test <- function() {

  loves_list <- list(
    c("Taro","Miki"),
    c("Jiro","Hanako"),
    c("Saburo","Hanako"),
    c("Daisuke","Youko"),
    c("Shunsuke","AnyGirl"),
    c("Masatoshi","AnyGirl"),
    c("Miki","Taro"),
    c("Hanako","Daisuke"),
    c("AnyGirl","Masao")
  )
  
  lover <- function(x) {
    for (p in loves_list) {
      if (x == p[1]) return(p[2])
    }
    return(NA)
  }

  do <- maybe_do

  couple_test <- function(a,b,lover) do (
    x %<-% lover(a),
    y %<-% lover(x),
    returm(x == b && y == a)
  )

  rival_test <- function(a,b,lover) do (
    x %<-% lover(a),
    y %<-% lover(b),
    returm(x == y)
  )

  jealousy_test <- function(a,b,lover) do (
    x %<-% lover(a),
    y %<-% lover(x),
    returm(y != a && y == b)
  )

  run <- function(test,a,b) {
    print(paste(substitute(test),a,"-->",b,":",test(a,b,lover)))
  }

  run(couple_test,"Taro","Miki")
  run(couple_test,"Jiro","Miki")
  run(couple_test,"Daisuke","Youko")
  run(rival_test,"Taro","Jiro")
  run(rival_test,"Jiro","Saburo")
  run(jealousy_test,"Shunsuke","Masao")
  run(jealousy_test,"Shunsuke","Taro")
  run(jealousy_test,"Jiro","Saburo")
}

maybe_test()