R-combinator-manipulation.md

R-lang combinator manipulation

• This is forked and summarized from https://github.com/TobCap/R/blob/774e60bff9805b37fd791ca40cc1b9d435c8dd19/functional_programming.r#L477-L516
• Before starting, execute bottom part of self-build functions

Y combinator

http://en.wikipedia.org/wiki/Fixed-point_combinator

compare below this R's expression with the Y combinator definition written in wikipedia!

`λ` <- l. <- function(..., env_ = parent.frame()) curry(f.(..., env_ = env_))
fib_maker <- function(f) function(x) if (x <= 1) x else f(x - 1) + f(x - 2)

# Wow, syntax looks similar to definition of Y-combinator, Church's lambda-notaion
# Y = λf.(λx.f (x x)) (λx.f (x x))
Y <- λ(f, (λ(x, f(x(x))))(λ(x, f(x(x)))))
Y(fib_maker)(10) # => 55

# by R base syntax
Y2 <- function(f) (function(x) f(function(y) x(x)(y)))(function(x) f(function(y) x(x)(y)))
Y2(fib_maker)(10) # => 55

fixed-point combinator

R can write very simply way

fix_ <- function(g) f <- g(f)
fix_(fib_maker)(10) # => 55

fix_2 <- function(f) f(fix_2(f))
fix_2(fib_maker)(10) # => 55

Z combinator

# Z = λf.(λx.f (λy. x x y)) (λx.f (λy. x x y))
Z <- λ(f, (λ(x, f (λ(y, x (x) (y))))) (λ(x, f (λ(y, x (x) (y))))))
Z(fib_maker)(10) # => 55

# by R base syntax
Z2 <- function(f) (function(x) function(y) f(x(x))(y))(function(x) function(y) f(x(x))(y))
Z2(fib_maker)(10) # => 55

SKI Combinator

see http://www.angelfire.com/tx4/cus/combinator/birds.html

S <- λ(x, λ(y, λ(z, (x(z))(y(z)))))
K <- λ(x, λ(y, x))
I <- S(K)(K) # == f.(x, x) == identity()

# Y combinator by SKI
Y_SKI <- S(K(S(I)(I)))(S(S(K(S))(K))(K(S(I)(I))))
Y_SKI(fib_maker)(10) # => 55

self-build functions

Need to load both f.() and curry() of simple version.

### function creator syntax-sugar
f. <- function (..., env_ = parent.frame()) {
  # auxiliary function
  as.formals <- function(xs) as.pairlist(tools:::as.alist.call(xs))

  d <- as.pairlist(as.vector(substitute((...)), "list")[-1])
  n <- length(d)
  eval(call("function", as.formals(d[-n]), d[[n]]), env_)
}
# f.(x, y, z, x + y + z) 
# => function(x, y, z) x + y + z

Simple version of currying function

curry <- function(f, env_ = parent.frame()) {
  stopifnot(typeof(f) == "closure")

  make_body <- function(args_) {
    if (length(args_) == 0)
        body(f)
    else
        call("function", as.pairlist(args_[1]), make_body(args_[-1]))
  }

  f_sym <- substitute(f)
  f_args <- formals(args(f))

  if (is.null(f_args)) f
  else eval(make_body(f_args), environment(f))
}

Strict version of currying function

### making an arbitrary function curried
curry <- function(f, env_ = parent.frame(), as_special = FALSE) {
  # `as_special = TRUE` is required if typeof(f) is "closure" and there are any language object handling 
  # functions such as substitute() or match.call() inside body(f)
  # 
  # curry(bquote)(a + .(b))(list(b = 10)) => expr
  # curry(bquote, as_special = TRUE)(a + .(b))(list(b = 10)) => a + 10

  # `ls`, `ls.str` # a function that checks a formal parameter w/o default value by `missing` will error

  # http://cran.r-project.org/doc/manuals/r-release/R-ints.html#Prototypes-for-primitives
  stopifnot(is.function(f) && !(typeof(f) == "special" && is.null(args(f))))
  # > names(Filter(function(f) is.function(f) && (typeof(f) == "special" && is.null(args(f))), as.list(baseenv())))
  #  [1] "$"        "="        "@"        "["        "{"        "~"        "repeat"   "return"   "&&"
  # [10] "next"     "@<-"      "<-"       "break"    "[["       "[[<-"     "if"       "$<-"      "||"
  # [19] "function" "while"    "for"      "[<-"      "<<-"

  make_body <- function(args_) {
    if (length(args_) == 0)
      switch(if (isTRUE(as_special)) "special" else typeof(f)
      , closure = body(f)
      , builtin = as.call(c(f, `names<-`(lapply(names(f_args), as.symbol), names(f_args))))
      , special = make_special_body()
      )
    else call("function", as.pairlist(args_[1]), make_body(args_[-1]))
  }

  make_special_body <- function() {
    # `f_sym`, `f_args`, `env_` are parent environment's variable
    bquote({
      
      f_sym <- .(f_sym)
      f_args_rev <- lapply(rev(names(.(f_args))), function(x) as.symbol(x))
      
      args_ <- list()
      e <- environment()
      
      while (length(f_args_rev) > 0) {
        f_args_head <- f_args_rev[[1]]
        
        arg_ <-
          if (f_args_head == "...")  as.list(methods::substituteDirect(call("list", f_args_head), e))[-1]
          else methods::substituteDirect(f_args_head, e)
          
        if (is.null(arg_)) arg_ <- list(NULL) # if default value is NULL
        args_ <- append(arg_, args_)
        
        # next loop
        f_args_rev <- f_args_rev[-1]
        e <- parent.env(e)
      }
      
      fun_new <- as.call(c(f_sym, args_))
      eval(fun_new, .(env_))
      # do.call(f_sym, args_, quote = TRUE, envir = .(env_))

    }, parent.env(environment()))
  }
  
  f_sym <- substitute(f)
  f_args <- formals(args(f))

  if (is.null(f_args)) f
  else eval(make_body(f_args), environment(f), baseenv())
  # baseenv() is used only if environment(f) is NULL; that means `f` is special or builtin function in baseenv()
  # except methods::Quote and methods::`el<-` that are S-Plus compatible functions
}