背景

O'REILLYの「アンダースタンディング コンピュテーション」はRubyで言語実装を行っているが、これをRのS4クラスで実装してみた。
どちらかというと、S4クラスの練習といった意味合いが強い。

コード

オブジェクトの継承構造などはコメントにあるとおり。Ruby風にするためにコンストラクタを呼び出すnew関数を別に定義している。
四則演算については足し算とかけ算、比較演算についてはLess Thanのみ。

#
# SIMPLE(Simple IMPerative LanguagE)
# small step of operational semantics described by R as a metalanguage 
# reference: Understanding Computation (in Japanese) Tom Stuart,O'REILLY(2014)
#
#
# Class Structure
# 
# Object --- Number
#         |- Boolean
#         |- BinaryOperator --- ArithmethicBinaryOperator --- Add
#         |                  |                             |- Multiply
#         |                  |- LogicalBinaryOperator --- LessThan
#         |- Machine
#

# -----------------------------------------------------------------------------
# Functions
# -----------------------------------------------------------------------------
Object.new <- function(x){return(new('Object'))}
Number.new <- function(x){return(new('Number',value = x))}
Boolean.new <- function(x){return(new('Boolean',value = x))}
Add.new <- function(l,r){return(new('Add',left = l,right = r))}
Multiply.new <- function(l,r){return(new('Multiply',left = l,right = r))}
LessThan.new <- function(l,r){return(new('LessThan',left = l,right = r))}
Machine.new <-function(x){return(new('Machine',expression = x))}


# -----------------------------------------------------------------------------
# Generic Functions
# -----------------------------------------------------------------------------
setGeneric('is.reducible',useAsDefault = function(x){return(x@reducible)})
setGeneric('do.reduce',useAsDefault = function(x){return(TRUE)})
setGeneric('lexpr',useAsDefault = function(x){return(TRUE)})
setGeneric('do.step',useAsDefault = function(x){return(TRUE)})
setGeneric('run',useAsDefault = function(x){return(TRUE)})

# -----------------------------------------------------------------------------
# Object class
# -----------------------------------------------------------------------------
setClass('Object',
    representation(reducible = 'logical'),
    prototype(reducible = FALSE))

# -----------------------------------------------------------------------------
# Number class
# -----------------------------------------------------------------------------
setClass('Number',
    representation(value = 'numeric'),
    contains = 'Object',
    prototype(reducible = FALSE))
setMethod('lexpr',signature(x = 'Number'),function(x){
    return(paste('',x@value,'',sep = ''))
    })

# -----------------------------------------------------------------------------
# Boolean class
# -----------------------------------------------------------------------------
setClass('Boolean',
    representation(value = 'logical'),
    contains = 'Object',
    prototype(reducible = FALSE))
setMethod('lexpr',signature(x = 'Boolean'),function(x){
    return(paste('',x@value,'',sep = ''))
    })

# -----------------------------------------------------------------------------
# Binary Operator class
# -----------------------------------------------------------------------------
setClass('BinaryOperator',
    representation(left = 'Object',right = 'Object',operator = 'character',reducedClass = 'character'),
    contains = 'Object',
    prototype(reducible = TRUE))
setMethod('lexpr',signature(x = 'BinaryOperator'),function(x){
    return(paste('[',x@operator,' ',lexpr(x@left),' ',lexpr(x@right),']',sep = ''))
    })
setMethod('do.reduce',signature(x = 'BinaryOperator'),function(x){
    if(is.reducible(x@left)){
        return(new(class(x)[1],left = do.reduce(x@left),right = x@right))
    }else if(is.reducible(x@right)){
        return(new(class(x)[1],left = x@left,right = do.reduce(x@right)))
    }else{
        return(
            new(x@reducedClass,value = eval(parse(text = paste('x@left@value',x@operator,'x@right@value',sep = ''))))
        )
    }
})

# -----------------------------------------------------------------------------
# Arithmetic Binary Oparator class
# -----------------------------------------------------------------------------
setClass('ArithmeticBinaryOperator',
    representation(),
    contains = 'BinaryOperator',
    prototype(reducible = TRUE,reducedClass = 'Number'))


# -----------------------------------------------------------------------------
# Logical Binary Oparator class
# -----------------------------------------------------------------------------
setClass('LogicalBinaryOperator',
    representation(),
    contains = 'BinaryOperator',
    prototype(reducible = TRUE,reducedClass = 'Boolean'))


# -----------------------------------------------------------------------------
# Add class
# -----------------------------------------------------------------------------
setClass('Add',
    representation(),
    contains = 'ArithmeticBinaryOperator',
    prototype(operator = '+'))

# -----------------------------------------------------------------------------
# Multiply class
# -----------------------------------------------------------------------------
setClass('Multiply',
    representation(),
    contains = 'ArithmeticBinaryOperator',
    prototype(operator = '*'))

# -----------------------------------------------------------------------------
# LessThan class
# -----------------------------------------------------------------------------
setClass('LessThan',
    representation(),
    contains = 'LogicalBinaryOperator',
    prototype(operator = '<'))

# -----------------------------------------------------------------------------
# Machine class
# -----------------------------------------------------------------------------
setClass('Machine',
    representation(expression = 'Object'),
    contains = 'Object',
    prototype())
setMethod('do.step',signature(x = 'Machine'),function(x){
    if(is.reducible(x@expression)){
        return(new('Machine',expression = do.reduce(x@expression)))
    }else{
        return(x)
    }
})
setMethod('run',signature(x = 'Machine'),function(x){
    while(is.reducible(x@expression)){
        print(lexpr(x@expression))
        x <- do.step(x)
    }
    print(lexpr(x@expression))
})
setMethod('lexpr',signature(x = 'Machine'),function(x){
    return(lexpr(x@expression))
})

# -----------------------------------------------------------------------------
# sample
# -----------------------------------------------------------------------------
n <- Number.new(10)
m <- Number.new(20)

x <- Add.new(n,m)
y <- Multiply.new(n,m)

lt <- LessThan.new(x,y)
aam <- Add.new(x,y) 

print('--- sample1 ---')
machine <- Machine.new(lt)
run(machine)

print('--- sample2 ---')
machine <- Machine.new(aam)
run(machine)