Help us understand the problem. What is going on with this article?

アンダースタンディング コンピュテーションのSIMPLEをRで実装してみた

More than 5 years have passed since last update.

背景

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)

Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away