A trivial example of Sussman's up/down tuples in R (not recursive yet)

S3-oop-tuples.R

# use R OOP (S3) to implement up/down tuples
# (as per GJS and SICM)

library(purrr)

# constructor
new_Struct <- function(stype , vec){
  stopifnot(is.character(stype)) # enforce up | down
  stopifnot(is.vector(vec))
  structure(vec,class="Struct", type=stype)
}

# constructor helper functions --- need to allow for nesting!
up <- function(...){
  vec <- unlist(list(...), use.names = FALSE)
  new_Struct("up",vec)
}
down <- function(...){
  vec <- unlist(list(...), use.names = FALSE)
  new_Struct("down",vec)
}

# generic print for tuples
print.Struct <- function(s){
  outstr <- sprintf("%s(%s)", attributes(s)$type, paste(c(s), collapse=", "))
  print(noquote(outstr))
}

# apply the structure - would be nice if this could be done *implicitly*
call <- function(...) UseMethod("call")
call.Struct <- function(s,x){
  new_Struct(attributes(s)$type, sapply(s, do.call, list(x)))
}

bothStructs <- function(x,y) {
  inherits(x,'Struct') && inherits(y,'Struct')
}

sameType <- function(x,y) { UseMethod('sameType', x) }
sameType.Struct <-function(x,y) {
  attributes(x)$type == attributes(y)$type
}

# + - if same
# multiplication as outer product if same
# contract (dot product) if opposite
# square (same) as dot product / square if == and *

Ops.Struct <- function(e1, e2) {
  if (nargs()==1) {
    switch(.Generic,
           '+' = {},
           '-' = { e1[] <- -unclass(e1) },
           # include these?  Hmm, probably not
           '*' = {},  # scmutils compatibility
           '<' = {},  # scmutils compatibility
           '>' = {},  # scmutils compatibility
           stop(gettextf("unary \'%s\' not defined for up/down tuples",.Generic),
                domain=NA, call. = FALSE))
    return(e1)
  }
  else if (nargs()==2){
    if(bothStructs(e1,e2)){
      samelength <- length(e1)==length(e2)
      if(sameType(e1,e2)){
        if(samelength) { # can be added, etc...
          switch(.Generic,
               '+' = { e1[] <- unclass(e1)+unclass(e2) },
               '-' = { e1[] <- unclass(e1)-unclass(e2) },
               '==' = { e1 <- every(unclass(e1)==unclass(e2), function(p) as.logical(p)) },
               '*' = {
                 if ( e1==e2 ){ # equal => square them!
                   e1 <- (e1%*%e2)[1] }
                 else { # outer product if same length but not equa;
                   e1 <- e1%o%e2 } 
                 },  
               stop(gettextf("\'%s\' not defined for tuples of same type and length",.Generic),
                    domain=NA, call. = FALSE))
        }
        else { # not same length - can only be multiplied
          switch(.Generic,
                 '==' = { e1 <- FALSE },
                 '*' = { e1 <- e1%o%e2 },  # outer product <= same type, diff lengths
                 stop(gettextf("\'%s\' not defined for tuples of different lengths",.Generic),
                      domain=NA, call. = FALSE))
          }
        return(e1)
        }
      else{ # opposite types - only * allows dot product
        switch(.Generic,
               '*' = { 
                 if(samelength){
                   outval <- (e1%*%e2)[1]  # dot product as matrix
                 }
                 else { 
                   stop(gettextf("Contraction (dot-product) factors must have same length!"), 
                        call. = FALSE)
                   }
                 },  
               '==' = {
                 outval <- FALSE 
                 },
               stop(gettextf("\'%s\' not defined for opposite tuple types",.Generic),
                    domain=NA, call. = FALSE)
               )
        return(outval)
        }
    }
    else { # not both structs
      if (inherits(e1,'Struct')) {
        # these DO allow numbers to map, i.e. "scale", essentially
        # basically we want default Ops behaviour
        switch(.Generic,
               '*' = {
                 e1[]<-unclass(e1) * unclass(e2)
                 },
               '^' = {
                 if (e2!=2) {
                   stop(gettextf("Only %s2 defined at present",.Generic),
                        call. = FALSE)
                 }
                 else {
                   square <- (e1%*%e1)[1]
                   e1 <- square
                 }},
               '==' = { e1 <- FALSE },
               stop(gettextf("\'%s\' is not defined for mapping on tuples",.Generic),
                    call. = FALSE)
              )
        return(e1)
      }
      else {
        switch(.Generic,
               '*' = {
                 e2[]<-unclass(e1) * unclass(e2)},
               '==' = { e2 <- FALSE },
               stop(gettextf("\'%s\' is not defined for mapping on tuples",.Generic),
                    call. = FALSE)
               )
        return(e2)
        }
     }
  }
  else {
    stop(gettextf("\'%s'\ not defined for >2 arguments", 
                .Generic), domain = NA)
    }
  }