Project

General

Profile

Bug #3781 » reduct.rb

metanest (Makoto Kishimoto), 09/02/2010 08:38 AM

 
# coding:utf-8
# vi:set ts=3 sw=3:
# vim:set sts=0 noet:

# History
#
# 0.0.1 2010/Aug/29

# Version
#
# 0.1dev

require "pp"

require "fiber"

module RDM
class RDMList
private_class_method :new

def inspect
"(#{inspect_}"
end

def inspect_
case self
when RDMNil then
")"
when RDMCons then
@car.inspect +
case @cdr
when RDMNil then
@cdr.inspect_
when RDMCons then
" #{@cdr.inspect_}"
else
" . #{@cdr.inspect})"
end
else
raise
end
end
end

class RDMNil < RDMList
Nil = new
end

class RDMCons < RDMList
public_class_method :new

attr_accessor :car, :cdr

def initialize car=RDMNil::Nil, cdr=RDMNil::Nil
@car, @cdr = car, cdr
end
end

class ProgNode
class P_List
private_class_method :new

def inspect cache={}
if !self.kind_of? P_Nil and cache.has_key? self then
return "[...]"
end
cache[self] = true
"[#{inspect_ cache}"
end

def inspect_ cache
case self
when P_Nil then
"]"
when P_Cons then
case @car
when P_List then
@car.inspect(cache)
else
@car.inspect
end +
case @cdr
when P_Nil then
@cdr.inspect_ cache
when P_Cons then
", #{@cdr.inspect_ cache}"
else
" . #{@cdr.inspect}]"
end
else
raise
end
end
end

class P_Nil < P_List
Nil = new
end

class P_Cons < P_List
public_class_method :new

attr_reader :car, :cdr

def initialize a, d
@car = a
@cdr = d
end
end

attr_reader :tag

def initialize
@tag = :undefined
end

def clear_instance_variables
instance_variables.each {|name|
remove_instance_variable name
}
end

def replace that
unless equal? that then
clear_instance_variables
that.instance_variables.each {|name|
instance_variable_set(name, that.instance_variable_get(name))
}
end
nil
end

def set_app fun, arg, &c
clear_instance_variables
@tag = :app
@car = fun
@cdr = arg
@proc = c
end

def set_val val, &c
clear_instance_variables
@tag = :val
@val = val
@proc = c
end

def set_lambda params, exp
clear_instance_variables
@tag = :lambda
@params = params
@exp = exp
end

def convert_lambda
n = ProgNode.new
n.set_lambda(@params, RDM.convert(@exp))
n
end

def car
unless @tag == :app then
return nil
end
@car
end

def cdr
unless @tag == :app then
return nil
end
@cdr
end

def val
unless @tag == :val then
return nil
end
@val
end

def method_missing name, *args
if m = /\Ac([ad]*)r\z/.match(name.to_s) then
if args.empty? then
p = self
m[1].reverse.each_char {|c|
case c
when "a" then
p = p.car
when "d" then
p = p.cdr
end
unless p then
return p
end
}
p
else
super
end
end
end

def inspect reminder={}
case @tag
when :val then
@val.inspect
when :app then
"(#{inspect_app reminder})"
when :lambda then
"{#{@params.inspect} #{@exp.inspect}}"
end
end

def inspect_app reminder
if reminder.has_key? self then
return "..."
end
if @tag == :app then
reminder[self] = true
"#{@car.inspect_app reminder} #{@cdr.inspect reminder}"
else
inspect
end
end

def compile
case @tag
when :val then
self
when :app then
a = @car.compile
d = @cdr.compile
ProgNode.make_appnode a, d
when :lambda then
e = @exp.compile
@params.reverse.each {|param|
e = e.abstract param
}
e
else
raise
end
end

def abstract param
case @tag
when :val then
if @val == param then
SYMNODES[:I]
else
ProgNode.make_appnode SYMNODES[:K], self
end
when :app then
a = @car.abstract param
d = @cdr.abstract param
prg = ProgNode.make_appnode SYMNODES[:S], a
prg = ProgNode.make_appnode prg, d
prg.simplify
else
raise
end
end

def simplify
exp = self
stk = []
e = exp
while e.tag == :app do
stk.push e
e = e.car
end
if (stk.size < 2) or stk[-1].car.val != :S then
return exp
end
# S (K p) (K q) ==> K (p q)
if stk[-1].cdr.tag == :app and
stk[-1].cadr.val == :K and
stk[-2].cdr.tag == :app and
stk[-2].cadr.val == :K then

p = stk[-1].cddr
q = stk[-2].cddr
p_q = ProgNode.make_appnode p, q
e = ProgNode.make_appnode SYMNODES[:K], p_q
return simplify_sub stk, e
# S (K p) I ==> p
elsif stk[-1].cdr.tag == :app and
stk[-1].cadr.val == :K and
stk[-2].cdr.val == :I then

e = stk[-1].cddr
return simplify_sub stk, e
# S (K p) (B q r) ==> B* p q r
elsif stk[-1].cdr.tag == :app and
stk[-1].cadr.val == :K and
stk[-2].cdr.tag == :app and
stk[-2].cadr.tag == :app and
stk[-2].caadr.val == :B then

p = stk[-1].cddr
q = stk[-2].cdadr
r = stk[-2].cddr
e = ProgNode.make_appnode SYMNODES[:"B*"], p
e = ProgNode.make_appnode e, q
e = ProgNode.make_appnode e, r
return simplify_sub stk, e
# S (K p) q ==> B p q
elsif stk[-1].cdr.tag == :app and
stk[-1].cadr.val == :K then

p = stk[-1].cddr
q = stk[-2].cdr
e = ProgNode.make_appnode SYMNODES[:B], p
e = ProgNode.make_appnode e, q
return simplify_sub stk, e
# S (B p q) (K r) ==> C' p q r
elsif stk[-1].cdr.tag == :app and
stk[-1].cadr.tag == :app and
stk[-1].caadr.val == :B and
stk[-2].cdr.tag == :app and
stk[-2].cadr.val == :K then

p = stk[-1].cdadr
q = stk[-1].cddr
r = stk[-2].cddr
e = ProgNode.make_appnode SYMNODES[:"C'"], p
e = ProgNode.make_appnode e, q
e = ProgNode.make_appnode e, r
return simplify_sub stk, e
# S p (K q) ==> C p q
elsif stk[-2].cdr.tag == :app and
stk[-2].cadr.val == :K then

p = stk[-1].cdr
q = stk[-2].cddr
e = ProgNode.make_appnode SYMNODES[:C], p
e = ProgNode.make_appnode e, q
return simplify_sub stk, e
# S (B p q) r ==> S' p q r
elsif stk[-1].cdr.tag == :app and
stk[-1].cadr.tag == :app and
stk[-1].caadr.val == :B then

p = stk[-1].cdadr
q = stk[-1].cddr
r = stk[-2].cdr
e = ProgNode.make_appnode SYMNODES[:"S'"], p
e = ProgNode.make_appnode e, q
e = ProgNode.make_appnode e, r
return simplify_sub stk, e
end
exp
end

def simplify_sub stk, e
p = e
# copy cells of stk[0 ... -2]
stk[0 ... -2].reverse.each {|cell|
p = ProgNode.make_appnode p, cell.cdr
}
p
end

def do_action intp
intp.instance_eval &@proc
end

# Blocks in following definitions are evaluated by Intp#instance_eval .

def self.make_valnode val
node = new
node.set_val(val){
return_sub
}
node
end

def self.make_dummynode val
node = new
node.set_val(val){
raise
}
node
end

def self.make_appnode fun, arg
node = new
node.set_app(fun, arg){
if @debug then
print "step: push car\n"
end
la_push la_tos.car
}
node
end

SYMNODES = {}

def self.regist_symnode sym, &c
node = new
node.set_val sym, &c
SYMNODES[sym] = node
end

regist_symnode(:S){
# S f g x --> f x (g x)
if @debug then
puts "step: reduction S"
puts la_bos.inspect
end
la_pop
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
f_x = ProgNode.make_appnode f, x
g_x = ProgNode.make_appnode g, x
newnode = ProgNode.make_appnode f_x, g_x
target_cell.replace newnode
la_push target_cell
}

regist_symnode(:K){
# K x y --> x
if @debug then
puts "step: reduction K"
puts la_bos.inspect
end
la_pop
x = la_pop.cdr
target_cell = la_pop
target_cell.replace x
la_push target_cell
}

regist_symnode(:I){
# I x --> x
if @debug then
puts "step: reduction I"
puts la_bos.inspect
end
la_pop
target_cell = la_pop
x = target_cell.cdr
target_cell.replace x
la_push target_cell
}

regist_symnode(:Y){
# Y f --> f (Y f) == f (f (f (...)))
if @debug then
puts "step: reduction Y"
puts la_bos.inspect
end
la_pop
target_cell = la_pop
f = target_cell.cdr
c = ProgNode.make_appnode f, target_cell
target_cell.replace c
la_push target_cell
}

regist_symnode(:B){
# B f g x --> f (g x)
if @debug then
puts "step: reduction B"
puts la_bos.inspect
end
la_pop
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
g_x = ProgNode.make_appnode g, x
f_g_x = ProgNode.make_appnode f, g_x
target_cell.replace f_g_x
la_push target_cell
}

regist_symnode(:C){
# C f g x --> f x g
if @debug then
puts "step: reduction C"
puts la_bos.inspect
end
la_pop
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
f_x = ProgNode.make_appnode f, x
f_x_g = ProgNode.make_appnode f_x, g
target_cell.replace f_x_g
la_push target_cell
}

regist_symnode(:"S'"){
# S' c f g x --> c (f x) (g x)
if @debug then
puts "step: reduction S'"
puts la_bos.inspect
end
la_pop
c = la_pop.cdr
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
f_x = ProgNode.make_appnode f, x
g_x = ProgNode.make_appnode g, x
c_f_x = ProgNode.make_appnode c, f_x
c_f_x_g_x = ProgNode.make_appnode c_f_x, g_x
target_cell.replace c_f_x_g_x
la_push target_cell
}

regist_symnode(:"B*"){
# B* c f g x --> c (f (g x))
if @debug then
puts "step: reduction B*"
puts la_bos.inspect
end
la_pop
c = la_pop.cdr
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
g_x = ProgNode.make_appnode g, x
f_g_x = ProgNode.make_appnode f, g_x
c_f_g_x = ProgNode.make_appnode c, f_g_x
target_cell.replace c_f_g_x
la_push target_cell
}

regist_symnode(:"C'"){
# C' c f g x --> c (f x) g
if @debug then
puts "step: reduction C'"
puts la_bos.inspect
end
la_pop
c = la_pop.cdr
f = la_pop.cdr
g = la_pop.cdr
target_cell = la_pop
x = target_cell.cdr
f_x = ProgNode.make_appnode f, x
c_f_x = ProgNode.make_appnode c, f_x
c_f_x_g = ProgNode.make_appnode c_f_x, g
target_cell.replace c_f_x_g
la_push target_cell
}

regist_symnode(:IF){
# IF c x y --> x OR y
if @debug then
puts "step: reduction IF"
puts la_bos.inspect
end
la_pop
c = la_pop.cdr
x = la_pop.cdr
target_cell = la_pop
y = target_cell.cdr
c = call_sub c
if @debug then
puts "return:"
puts target_cell.inspect
end
r = if c.val == 0 then
y
else
x
end
target_cell.replace r
la_push target_cell
}

regist_symnode(:<=){
# <= x y --> 0 OR 1
if @debug then
puts "step: reduction <="
puts la_bos.inspect
end
la_pop
x = la_pop.cdr
target_cell = la_pop
y = target_cell.cdr
x = call_sub x
y = call_sub y
if @debug then
puts "return:"
puts target_cell.inspect
end
r = if x.val <= y.val then
1
else
0
end
newnode = ProgNode.make_valnode r
target_cell.replace newnode
la_push target_cell
}

regist_symnode(:+){
# + x y --> (eval x) + (eval y)
if @debug then
puts "step: reduction +"
puts la_bos.inspect
end
la_pop
x = la_pop.cdr
target_cell = la_pop
y = target_cell.cdr
x = call_sub x
y = call_sub y
if @debug then
puts "return:"
puts target_cell.inspect
end
r = x.val + y.val
newnode = ProgNode.make_valnode r
target_cell.replace newnode
la_push target_cell
}

regist_symnode(:-){
# - x y --> (eval x) - (eval y)
if @debug then
puts "step: reduction -"
puts la_bos.inspect
end
la_pop
x = la_pop.cdr
target_cell = la_pop
y = target_cell.cdr
x = call_sub x
y = call_sub y
if @debug then
puts "return:"
puts target_cell.inspect
end
r = x.val - y.val
newnode = ProgNode.make_valnode r
target_cell.replace newnode
la_push target_cell
}

regist_symnode(:*){
# * x y --> (eval x) * (eval y)
if @debug then
puts "step: reduction *"
puts la_bos.inspect
end
la_pop
x = la_pop.cdr
target_cell = la_pop
y = target_cell.cdr
x = call_sub x
y = call_sub y
if @debug then
puts "return:"
puts target_cell.inspect
end
r = x.val * y.val
newnode = ProgNode.make_valnode r
target_cell.replace newnode
la_push target_cell
}
end

class Intp
attr_accessor :debug

def initialize
@la_stack = nil # left ancestors stack
@debug = false
@c_stack = [] # control stack
end

def trace_on
@debug = true
end

def trace_off
@debug = true
end

def la_push x
@la_stack.push x
end

def la_pop
@la_stack.pop
end

def la_bos # bottom of stack
@la_stack[0]
end

def la_tos # top of stack
@la_stack[-1]
end

def la_hasone?
@la_stack.size == 1
end

def setup exp
@la_stack = [exp]
@c_stack.push(
Fiber.new {
loop {
la_tos.do_action self
Fiber.yield nil
}
}
)
end

def step
@c_stack[-1].resume
end

def call_sub exp
if @debug then
puts "call:"
puts exp.inspect
end
@c_stack.push @la_stack
setup exp
Fiber.yield nil
end

def return_sub
r = la_pop
@c_stack.pop
@la_stack = @c_stack.pop
if @c_stack.empty? then
Fiber.yield r # exit step method
else
@c_stack[-1].resume r # resume call_sub method with r
end
end
end

def self.read str
str = str.lstrip
if str[0, 2] == "(\\" then
str = str[2 .. -1]
lst, str = read_list str
node = ProgNode.new
params = []
p = lst.car
while p != RDMNil::Nil do
params << p.car
p = p.cdr
end
node.set_lambda params, lst.cdr
[node, str]
elsif str[0, 2] == "'(" then
str = str[2 .. -1]
lst, str = read_list str
lst = read_convlist lst
[lst, str]
elsif str[0] == "(" then
str = str[1 .. -1]
read_list str
elsif str[0] == "\"" then
idx = str.index(/[^\\]"/, 1) + 1
s = str[1 ... idx]
s = s.gsub(/\\/){""} # XXX
[s, str[idx + 1 .. -1]]
elsif m = /\A([0-9]+)/.match(str) then
s = m[1]
str = str[s.length .. -1]
[s.to_i, str]
elsif m = /\A([-!'*+<=>?A-Z_a-z][-!'*+0-9<=>?A-Z_a-z]*)/.match(str) then
s = m[1]
str = str[s.length .. -1]
[s.to_sym, str]
else
raise "read error: \"#{str}\""
end
end

def self.read_list str
str = str.lstrip
if str[0] == ")" then
str = str[1 .. -1]
[RDMNil::Nil, str]
else
val, str = read str
cell = RDMCons.new val
str = str.lstrip
if str[0] == "." then
str = str[1 .. -1]
val, str = read str
str = str.lstrip
if str[0] == ")" then
str = str[1 .. -1]
cell.cdr = val
[cell, str]
else
raise "read error: \"#{str}\""
end
else
val, str = read_list str
cell.cdr = val
[cell, str]
end
end
end

def self.read_convlist lst
case lst
when RDMNil then
ProgNode::P_Nil::Nil
when RDMCons then
ProgNode::P_Cons.new(read_convlist(lst.car), read_convlist(lst.cdr))
else
lst
end
end

# convert lisp s-expression style tree to
# ProgNode tree
def self.convert exp
if exp.kind_of? RDMCons then
case exp.cdr
when RDMCons then
conv_(convert(exp.car), exp.cdr)
when RDMNil then
convert exp.car
else
raise
end
elsif exp.kind_of? ProgNode and exp.tag == :lambda then
exp.convert_lambda
elsif exp.kind_of? ProgNode
raise
elsif exp.kind_of? Symbol
if ProgNode::SYMNODES.has_key? exp then
ProgNode::SYMNODES[exp]
else
ProgNode.make_dummynode exp
end
else
ProgNode.make_valnode exp
end
end

def self.conv_ e, e2
n = ProgNode.make_appnode(e, convert(e2.car))
case e2.cdr
when RDMNil then
n
else
conv_ n, e2.cdr
end
end
end

src = RDM.read("((\\(tarai) tarai 100 50 0) (Y (\\(tarai x y z) IF (<= x y) y (tarai (tarai (- x 1) y z) (tarai (- y 1) z x) (tarai (- z 1) x y)))))")[0]
#puts src.inspect
prg = RDM.convert src
#puts prg.inspect
prg = prg.compile
#puts prg.inspect

intp = RDM::Intp.new
#intp.trace_on
intp.setup prg
begin
r = intp.step
end until r

print "result = #{r.val}\n"
(1-1/2)