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

背景

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)