In iqis/object: Types and Features for Object Oriented Programming

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>", 
  error = TRUE
)

library(Q7)

Dogs

Dog <- type(function(name, breed){
    say <- function(greeting = "Woof!"){
        cat(paste0(greeting, 
                   " I am ", name, ", a ", breed, 
                   ".\n"))
    }    
})

walter <- Dog("Walter", "Husky")
ls(walter)

walter$say()

max <- walter %>% 
  clone() %>% 
  implement({
    name <- "Max"
  })
max$say("Wussup Dawg!")

max %>% 
  implement({
    treats_eaten <- 0
    eat_treat <- function(n = 1){
      cat(paste(name, "eats", n, "treat(s).\n"))
      treats_eaten <<- treats_eaten + n
    }
  }) %>% 
  implement({
    is_satisfied <- function(){
      treats_eaten > 5
    }
  })

max$eat_treat()
max$is_satisfied()
max$eat_treat(2)
max$is_satisfied()
max$eat_treat(3)
max$is_satisfied()

max$treats_eaten

hasCollar <- feature({
  Collar <- type(function(material, color){
    description <- function() {
      paste("is made of", material, "and in", color)
    }
  })

  take_for_a_walk <- function(){
    cat(name, "wears a collar that", collar$description(), "\n")
    cat("We're gonna go out for a walk!")
  }
})

walter %>%
  implement({
    hasCollar()
    collar <- Collar("metal", "red")
    rm(Collar)
  })

walter$take_for_a_walk()

Workplace Overtime

Employee <- type(function(weekly_hours){}, "Employee")
john <- Employee(45)

Manager <- type(function(weekly_hours){
  extend(Employee)(weekly_hours)
  final[is_manager] <- TRUE
}, "Manager")

mike <- Manager(45)

hasOvertime <- feature_generic("hasOvertime")

hasOvertime.Employee <- feature({
  is_overtime <- function() weekly_hours > 40
})

hasOvertime.Manager <- feature({
  is_overtime <- function() FALSE
})

john %>% hasOvertime()
john$is_overtime()

mike %>% hasOvertime()
mike$is_overtime()

hasOvertime.Boss <- feature({
  final[is_overtime] <- function(){
    FALSE
  }
})

Boss <- 
  type({
    extend(Employee)(24 * 7)
  }, 
  "Boss") %>% 
  hasOvertime()

jill <- Boss()
jill$is_overtime()

Grade School Geometry

Circle <- type(
  function(radius){}, 
  "Circle")

Square <- type(
  function(side){}, 
  "Square")

hasArea <- feature_generic("hasArea")

hasArea.Square <- 
    feature({
        area <- function(){
            side ^ 2
        }
    })

hasArea.Circle <- 
    feature({
        area <- function(){
            radius^2 * pi
        }
    })

circle <- Circle(1) %>% hasArea()
circle$area()

square <- Square(1.5) %>% hasArea()
square$area()

hasArea.EquilateralTriangle <- feature({
    area <- function(){
        (side^2 * sqrt(3)) / 4
    }
})

EquilateralTriangle <- type(
  function(side){}, 
  "EquilateralTriangle") %>%
    hasArea()

equilateral_triangle <- EquilateralTriangle(1)
equilateral_triangle$area()

Locked

isLocked <- feature({
    lockEnvironment(.my, bindings = TRUE)
})

TestLocked <- type(function(){
    a <- 1
}) %>% isLocked()

test_locked <- TestLocked()
try(test_locked$a <- 666)
try(test_locked$b <- 666)
try({
  test_locked %>% 
    implement({
      a <- 666
    })
})

State Machine

This simple state machine guards a secret message with a password.

State <- type(
  function(password, secret_message = ""){
    name <- "DEFAULT"
    cat("Processing Current State...\n")
    print_current_state <- function(){
      cat(paste("Current State:", name, "\n"))
    }
})

LockedState <- State %>%
    implement({
        name <- "Locked"
        print_current_state()
        on_event <- function(event) {
            if (event == password) {
              cat("Access Granted.\n")
              return(UnlockedState(password, secret_message))
            } else {
              cat("Wrong Password. Access Denied.\n")
              return(.my)
            }
        }
    })

UnlockedState <- State %>%
  implement({
    name <- "Unlocked"
    print_current_state()

    private[print_secret_message] <- function(){
      cat(secret_message)
    }

    on_event <- function(event) {
      if (event == password) {
        return(LockedState(password, secret_message))
      } else if (event == "show") {
        print_secret_message()
        return(.my)
      } else{
        cat("Invalid Instruction. \n")
        return(.my)
      }
    }
  })

SimpleDevice <- type(function(password, secret_message){
    state <- LockedState(password, secret_message)
    on_event <- function(event){
        state <<- state$on_event(event)
    }
})

device <- SimpleDevice(password = "xxx", 
                       secret_message = "I love you.")

device$on_event("1234")
device$on_event("PvmpKinM4n777")

device$on_event("xxx")

device$on_event("fiddlin...")
device$on_event("meddlin...")
device$on_event("show")

device$on_event("xxx")

device$on_event("0000")

Parameterized features?

feature is subordinate to and dependent on type. It is encouraged to put all data members in a type definition, while feature mainly contain functions. If you feel significant need to parameterize a feature, think if it's better to create a nested object or to formally extend a type. You can always re-define something in a feature post hoc.

This will be implemented in the future.

Word <- type(function(word){})
hasRepeat <- feature({
  N_TIMES <- 2
  repeat_word <- function(){
    cat(rep(word, N_TIMES))
  }
})

apple <- Word("apple") %>% hasRepeat()
apple$repeat_word()

pear <- Word("pear") %>% 
  implement({
    hasRepeat()
    N_TIMES <- 5
  })
pear$repeat_word()

repeatWordNTimes <- function(word, times){
  localize(Word)(word) %>% 
    hasRepeat() %>% 
    implement({
      N_TIMES <- times
    })
}

orange <- repeatWordNTimes("orange", 7)
orange$repeat_word()

isIterable <- feature_generic("isIterable")

isIterable.default <- feature({
    forEach <- function(fn){
        Vector(sapply(elementData, fn))
    }

    final[is_iterable] <- TRUE
})

isLocked <- feature({
    lockEnvironment(.my, bindings = TRUE)
})

Vector <- type(function(elementData){
    elementData <- elementData
    elementCount <- length(elementData)

    add <- function(e){
        unlockBinding("elementData", .my)
        unlockBinding("elementCount", .my)
            elementData <<- c(elementData, e)
            elementCount <<- length(elementData)
        lockBinding("elementData", .my)
        lockBinding("elementCount", .my)
        invisible(.my)
    }

    remove <- function(index){
        unlockBinding("elementData", .my)
        unlockBinding("elementCount", .my)
            elementData <<- elementData[-index - 1]
            elementCount <<- length(elementData)
        lockBinding("elementData", .my)
        lockBinding("elementCount", .my)
        invisible(.my)
        }

    clear <- function(){
        unlockBinding("elementData", .my)
        unlockBinding("elementCount", .my)
        elementData <<- c()
        elementCount <<- length(elementData)
        lockBinding("elementData", .my)
        lockBinding("elementCount", .my)
        invisible(.my)
    }

    firstElement <- function(){
        elementData[1]
    }
    lastElement <- function(){
        elementData[elementCount]
    }
}, "Vector")  %>%
    isIterable() %>%
    isLocked()

nums <- Vector(c(1,2,3))
nums$elementData
nums$add(4)
nums$elementData
nums$elementCount

nums$remove(0)
nums$elementData

nums$clear()
nums$elementData
nums$elementCount

nums$add(c(554, 665, 776))
nums$elementData

nums$is_iterable <- FALSE

plus_one <- function(x){
    x + 1
}

nums2 <- nums$
    forEach(plus_one)$
    remove(0)$
    add(c(888, 999))

nums2$elementData

Microwave

Microwave <- type(function(){
  food <- NULL
  put_food <- function(food){
    if (!is.null(.my$food)) {
      stop("There's already food.")
    } else {
      .my$food <- food
    }
  }

  check_food <- function(){
    if (is.null(food)) {
      cat("Empty.\n")
    } else {
      cat(paste("The food is", food, "\n"))
    }
  }

  heat <- function(seconds){

    cat(paste(food, 
              "is heated for",
              paste0(seconds, "s\n")))

  }

  remove_food <- function(){
    food <<- NULL
  }

})

microwave <- Microwave()
microwave$check_food()
microwave$put_food("chicken dinner")
microwave$put_food("meatballs")
microwave$heat(30)
microwave$remove_food()
microwave$put_food("meatballs")
microwave$check_food()
microwave$heat(40)