1

# coding:utf8

2

# vi:set ts=3 sw=3:

3

# vim:set sts=0 noet:

4


5

# History

6

#

7

# 0.0.1 2010/Aug/29

8


9

# Version

10

#

11

# 0.1dev

12


13

require "pp"

14


15

require "fiber"

16


17

module RDM

18

class RDMList

19

private_class_method :new

20


21

def inspect

22

"(#{inspect_}"

23

end

24


25

def inspect_

26

case self

27

when RDMNil then

28

")"

29

when RDMCons then

30

@car.inspect +

31

case @cdr

32

when RDMNil then

33

@cdr.inspect_

34

when RDMCons then

35

" #{@cdr.inspect_}"

36

else

37

" . #{@cdr.inspect})"

38

end

39

else

40

raise

41

end

42

end

43

end

44


45

class RDMNil < RDMList

46

Nil = new

47

end

48


49

class RDMCons < RDMList

50

public_class_method :new

51


52

attr_accessor :car, :cdr

53


54

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

55

@car, @cdr = car, cdr

56

end

57

end

58


59

class ProgNode

60

class P_List

61

private_class_method :new

62


63

def inspect cache={}

64

if !self.kind_of? P_Nil and cache.has_key? self then

65

return "[...]"

66

end

67

cache[self] = true

68

"[#{inspect_ cache}"

69

end

70


71

def inspect_ cache

72

case self

73

when P_Nil then

74

"]"

75

when P_Cons then

76

case @car

77

when P_List then

78

@car.inspect(cache)

79

else

80

@car.inspect

81

end +

82

case @cdr

83

when P_Nil then

84

@cdr.inspect_ cache

85

when P_Cons then

86

", #{@cdr.inspect_ cache}"

87

else

88

" . #{@cdr.inspect}]"

89

end

90

else

91

raise

92

end

93

end

94

end

95


96

class P_Nil < P_List

97

Nil = new

98

end

99


100

class P_Cons < P_List

101

public_class_method :new

102


103

attr_reader :car, :cdr

104


105

def initialize a, d

106

@car = a

107

@cdr = d

108

end

109

end

110


111

attr_reader :tag

112


113

def initialize

114

@tag = :undefined

115

end

116


117

def clear_instance_variables

118

instance_variables.each {name

119

remove_instance_variable name

120

}

121

end

122


123

def replace that

124

unless equal? that then

125

clear_instance_variables

126

that.instance_variables.each {name

127

instance_variable_set(name, that.instance_variable_get(name))

128

}

129

end

130

nil

131

end

132


133

def set_app fun, arg, &c

134

clear_instance_variables

135

@tag = :app

136

@car = fun

137

@cdr = arg

138

@proc = c

139

end

140


141

def set_val val, &c

142

clear_instance_variables

143

@tag = :val

144

@val = val

145

@proc = c

146

end

147


148

def set_lambda params, exp

149

clear_instance_variables

150

@tag = :lambda

151

@params = params

152

@exp = exp

153

end

154


155

def convert_lambda

156

n = ProgNode.new

157

n.set_lambda(@params, RDM.convert(@exp))

158

n

159

end

160


161

def car

162

unless @tag == :app then

163

return nil

164

end

165

@car

166

end

167


168

def cdr

169

unless @tag == :app then

170

return nil

171

end

172

@cdr

173

end

174


175

def val

176

unless @tag == :val then

177

return nil

178

end

179

@val

180

end

181


182

def method_missing name, *args

183

if m = /\Ac([ad]*)r\z/.match(name.to_s) then

184

if args.empty? then

185

p = self

186

m[1].reverse.each_char {c

187

case c

188

when "a" then

189

p = p.car

190

when "d" then

191

p = p.cdr

192

end

193

unless p then

194

return p

195

end

196

}

197

p

198

else

199

super

200

end

201

end

202

end

203


204

def inspect reminder={}

205

case @tag

206

when :val then

207

@val.inspect

208

when :app then

209

"(#{inspect_app reminder})"

210

when :lambda then

211

"{#{@params.inspect} #{@exp.inspect}}"

212

end

213

end

214


215

def inspect_app reminder

216

if reminder.has_key? self then

217

return "..."

218

end

219

if @tag == :app then

220

reminder[self] = true

221

"#{@car.inspect_app reminder} #{@cdr.inspect reminder}"

222

else

223

inspect

224

end

225

end

226


227

def compile

228

case @tag

229

when :val then

230

self

231

when :app then

232

a = @car.compile

233

d = @cdr.compile

234

ProgNode.make_appnode a, d

235

when :lambda then

236

e = @exp.compile

237

@params.reverse.each {param

238

e = e.abstract param

239

}

240

e

241

else

242

raise

243

end

244

end

245


246

def abstract param

247

case @tag

248

when :val then

249

if @val == param then

250

SYMNODES[:I]

251

else

252

ProgNode.make_appnode SYMNODES[:K], self

253

end

254

when :app then

255

a = @car.abstract param

256

d = @cdr.abstract param

257

prg = ProgNode.make_appnode SYMNODES[:S], a

258

prg = ProgNode.make_appnode prg, d

259

prg.simplify

260

else

261

raise

262

end

263

end

264


265

def simplify

266

exp = self

267

stk = []

268

e = exp

269

while e.tag == :app do

270

stk.push e

271

e = e.car

272

end

273

if (stk.size < 2) or stk[1].car.val != :S then

274

return exp

275

end

276

# S (K p) (K q) ==> K (p q)

277

if stk[1].cdr.tag == :app and

278

stk[1].cadr.val == :K and

279

stk[2].cdr.tag == :app and

280

stk[2].cadr.val == :K then

281


282

p = stk[1].cddr

283

q = stk[2].cddr

284

p_q = ProgNode.make_appnode p, q

285

e = ProgNode.make_appnode SYMNODES[:K], p_q

286

return simplify_sub stk, e

287

# S (K p) I ==> p

288

elsif stk[1].cdr.tag == :app and

289

stk[1].cadr.val == :K and

290

stk[2].cdr.val == :I then

291


292

e = stk[1].cddr

293

return simplify_sub stk, e

294

# S (K p) (B q r) ==> B* p q r

295

elsif stk[1].cdr.tag == :app and

296

stk[1].cadr.val == :K and

297

stk[2].cdr.tag == :app and

298

stk[2].cadr.tag == :app and

299

stk[2].caadr.val == :B then

300


301

p = stk[1].cddr

302

q = stk[2].cdadr

303

r = stk[2].cddr

304

e = ProgNode.make_appnode SYMNODES[:"B*"], p

305

e = ProgNode.make_appnode e, q

306

e = ProgNode.make_appnode e, r

307

return simplify_sub stk, e

308

# S (K p) q ==> B p q

309

elsif stk[1].cdr.tag == :app and

310

stk[1].cadr.val == :K then

311


312

p = stk[1].cddr

313

q = stk[2].cdr

314

e = ProgNode.make_appnode SYMNODES[:B], p

315

e = ProgNode.make_appnode e, q

316

return simplify_sub stk, e

317

# S (B p q) (K r) ==> C' p q r

318

elsif stk[1].cdr.tag == :app and

319

stk[1].cadr.tag == :app and

320

stk[1].caadr.val == :B and

321

stk[2].cdr.tag == :app and

322

stk[2].cadr.val == :K then

323


324

p = stk[1].cdadr

325

q = stk[1].cddr

326

r = stk[2].cddr

327

e = ProgNode.make_appnode SYMNODES[:"C'"], p

328

e = ProgNode.make_appnode e, q

329

e = ProgNode.make_appnode e, r

330

return simplify_sub stk, e

331

# S p (K q) ==> C p q

332

elsif stk[2].cdr.tag == :app and

333

stk[2].cadr.val == :K then

334


335

p = stk[1].cdr

336

q = stk[2].cddr

337

e = ProgNode.make_appnode SYMNODES[:C], p

338

e = ProgNode.make_appnode e, q

339

return simplify_sub stk, e

340

# S (B p q) r ==> S' p q r

341

elsif stk[1].cdr.tag == :app and

342

stk[1].cadr.tag == :app and

343

stk[1].caadr.val == :B then

344


345

p = stk[1].cdadr

346

q = stk[1].cddr

347

r = stk[2].cdr

348

e = ProgNode.make_appnode SYMNODES[:"S'"], p

349

e = ProgNode.make_appnode e, q

350

e = ProgNode.make_appnode e, r

351

return simplify_sub stk, e

352

end

353

exp

354

end

355


356

def simplify_sub stk, e

357

p = e

358

# copy cells of stk[0 ... 2]

359

stk[0 ... 2].reverse.each {cell

360

p = ProgNode.make_appnode p, cell.cdr

361

}

362

p

363

end

364


365

def do_action intp

366

intp.instance_eval &@proc

367

end

368


369

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

370


371

def self.make_valnode val

372

node = new

373

node.set_val(val){

374

return_sub

375

}

376

node

377

end

378


379

def self.make_dummynode val

380

node = new

381

node.set_val(val){

382

raise

383

}

384

node

385

end

386


387

def self.make_appnode fun, arg

388

node = new

389

node.set_app(fun, arg){

390

if @debug then

391

print "step: push car\n"

392

end

393

la_push la_tos.car

394

}

395

node

396

end

397


398

SYMNODES = {}

399


400

def self.regist_symnode sym, &c

401

node = new

402

node.set_val sym, &c

403

SYMNODES[sym] = node

404

end

405


406

regist_symnode(:S){

407

# S f g x > f x (g x)

408

if @debug then

409

puts "step: reduction S"

410

puts la_bos.inspect

411

end

412

la_pop

413

f = la_pop.cdr

414

g = la_pop.cdr

415

target_cell = la_pop

416

x = target_cell.cdr

417

f_x = ProgNode.make_appnode f, x

418

g_x = ProgNode.make_appnode g, x

419

newnode = ProgNode.make_appnode f_x, g_x

420

target_cell.replace newnode

421

la_push target_cell

422

}

423


424

regist_symnode(:K){

425

# K x y > x

426

if @debug then

427

puts "step: reduction K"

428

puts la_bos.inspect

429

end

430

la_pop

431

x = la_pop.cdr

432

target_cell = la_pop

433

target_cell.replace x

434

la_push target_cell

435

}

436


437

regist_symnode(:I){

438

# I x > x

439

if @debug then

440

puts "step: reduction I"

441

puts la_bos.inspect

442

end

443

la_pop

444

target_cell = la_pop

445

x = target_cell.cdr

446

target_cell.replace x

447

la_push target_cell

448

}

449


450

regist_symnode(:Y){

451

# Y f > f (Y f) == f (f (f (...)))

452

if @debug then

453

puts "step: reduction Y"

454

puts la_bos.inspect

455

end

456

la_pop

457

target_cell = la_pop

458

f = target_cell.cdr

459

c = ProgNode.make_appnode f, target_cell

460

target_cell.replace c

461

la_push target_cell

462

}

463


464

regist_symnode(:B){

465

# B f g x > f (g x)

466

if @debug then

467

puts "step: reduction B"

468

puts la_bos.inspect

469

end

470

la_pop

471

f = la_pop.cdr

472

g = la_pop.cdr

473

target_cell = la_pop

474

x = target_cell.cdr

475

g_x = ProgNode.make_appnode g, x

476

f_g_x = ProgNode.make_appnode f, g_x

477

target_cell.replace f_g_x

478

la_push target_cell

479

}

480


481

regist_symnode(:C){

482

# C f g x > f x g

483

if @debug then

484

puts "step: reduction C"

485

puts la_bos.inspect

486

end

487

la_pop

488

f = la_pop.cdr

489

g = la_pop.cdr

490

target_cell = la_pop

491

x = target_cell.cdr

492

f_x = ProgNode.make_appnode f, x

493

f_x_g = ProgNode.make_appnode f_x, g

494

target_cell.replace f_x_g

495

la_push target_cell

496

}

497


498

regist_symnode(:"S'"){

499

# S' c f g x > c (f x) (g x)

500

if @debug then

501

puts "step: reduction S'"

502

puts la_bos.inspect

503

end

504

la_pop

505

c = la_pop.cdr

506

f = la_pop.cdr

507

g = la_pop.cdr

508

target_cell = la_pop

509

x = target_cell.cdr

510

f_x = ProgNode.make_appnode f, x

511

g_x = ProgNode.make_appnode g, x

512

c_f_x = ProgNode.make_appnode c, f_x

513

c_f_x_g_x = ProgNode.make_appnode c_f_x, g_x

514

target_cell.replace c_f_x_g_x

515

la_push target_cell

516

}

517


518

regist_symnode(:"B*"){

519

# B* c f g x > c (f (g x))

520

if @debug then

521

puts "step: reduction B*"

522

puts la_bos.inspect

523

end

524

la_pop

525

c = la_pop.cdr

526

f = la_pop.cdr

527

g = la_pop.cdr

528

target_cell = la_pop

529

x = target_cell.cdr

530

g_x = ProgNode.make_appnode g, x

531

f_g_x = ProgNode.make_appnode f, g_x

532

c_f_g_x = ProgNode.make_appnode c, f_g_x

533

target_cell.replace c_f_g_x

534

la_push target_cell

535

}

536


537

regist_symnode(:"C'"){

538

# C' c f g x > c (f x) g

539

if @debug then

540

puts "step: reduction C'"

541

puts la_bos.inspect

542

end

543

la_pop

544

c = la_pop.cdr

545

f = la_pop.cdr

546

g = la_pop.cdr

547

target_cell = la_pop

548

x = target_cell.cdr

549

f_x = ProgNode.make_appnode f, x

550

c_f_x = ProgNode.make_appnode c, f_x

551

c_f_x_g = ProgNode.make_appnode c_f_x, g

552

target_cell.replace c_f_x_g

553

la_push target_cell

554

}

555


556

regist_symnode(:IF){

557

# IF c x y > x OR y

558

if @debug then

559

puts "step: reduction IF"

560

puts la_bos.inspect

561

end

562

la_pop

563

c = la_pop.cdr

564

x = la_pop.cdr

565

target_cell = la_pop

566

y = target_cell.cdr

567

c = call_sub c

568

if @debug then

569

puts "return:"

570

puts target_cell.inspect

571

end

572

r = if c.val == 0 then

573

y

574

else

575

x

576

end

577

target_cell.replace r

578

la_push target_cell

579

}

580


581

regist_symnode(:<=){

582

# <= x y > 0 OR 1

583

if @debug then

584

puts "step: reduction <="

585

puts la_bos.inspect

586

end

587

la_pop

588

x = la_pop.cdr

589

target_cell = la_pop

590

y = target_cell.cdr

591

x = call_sub x

592

y = call_sub y

593

if @debug then

594

puts "return:"

595

puts target_cell.inspect

596

end

597

r = if x.val <= y.val then

598

1

599

else

600

0

601

end

602

newnode = ProgNode.make_valnode r

603

target_cell.replace newnode

604

la_push target_cell

605

}

606


607

regist_symnode(:+){

608

# + x y > (eval x) + (eval y)

609

if @debug then

610

puts "step: reduction +"

611

puts la_bos.inspect

612

end

613

la_pop

614

x = la_pop.cdr

615

target_cell = la_pop

616

y = target_cell.cdr

617

x = call_sub x

618

y = call_sub y

619

if @debug then

620

puts "return:"

621

puts target_cell.inspect

622

end

623

r = x.val + y.val

624

newnode = ProgNode.make_valnode r

625

target_cell.replace newnode

626

la_push target_cell

627

}

628


629

regist_symnode(:){

630

#  x y > (eval x)  (eval y)

631

if @debug then

632

puts "step: reduction "

633

puts la_bos.inspect

634

end

635

la_pop

636

x = la_pop.cdr

637

target_cell = la_pop

638

y = target_cell.cdr

639

x = call_sub x

640

y = call_sub y

641

if @debug then

642

puts "return:"

643

puts target_cell.inspect

644

end

645

r = x.val  y.val

646

newnode = ProgNode.make_valnode r

647

target_cell.replace newnode

648

la_push target_cell

649

}

650


651

regist_symnode(:*){

652

# * x y > (eval x) * (eval y)

653

if @debug then

654

puts "step: reduction *"

655

puts la_bos.inspect

656

end

657

la_pop

658

x = la_pop.cdr

659

target_cell = la_pop

660

y = target_cell.cdr

661

x = call_sub x

662

y = call_sub y

663

if @debug then

664

puts "return:"

665

puts target_cell.inspect

666

end

667

r = x.val * y.val

668

newnode = ProgNode.make_valnode r

669

target_cell.replace newnode

670

la_push target_cell

671

}

672

end

673


674

class Intp

675

attr_accessor :debug

676


677

def initialize

678

@la_stack = nil # left ancestors stack

679

@debug = false

680

@c_stack = [] # control stack

681

end

682


683

def trace_on

684

@debug = true

685

end

686


687

def trace_off

688

@debug = true

689

end

690


691

def la_push x

692

@la_stack.push x

693

end

694


695

def la_pop

696

@la_stack.pop

697

end

698


699

def la_bos # bottom of stack

700

@la_stack[0]

701

end

702


703

def la_tos # top of stack

704

@la_stack[1]

705

end

706


707

def la_hasone?

708

@la_stack.size == 1

709

end

710


711

def setup exp

712

@la_stack = [exp]

713

@c_stack.push(

714

Fiber.new {

715

loop {

716

la_tos.do_action self

717

Fiber.yield nil

718

}

719

}

720

)

721

end

722


723

def step

724

@c_stack[1].resume

725

end

726


727

def call_sub exp

728

if @debug then

729

puts "call:"

730

puts exp.inspect

731

end

732

@c_stack.push @la_stack

733

setup exp

734

Fiber.yield nil

735

end

736


737

def return_sub

738

r = la_pop

739

@c_stack.pop

740

@la_stack = @c_stack.pop

741

if @c_stack.empty? then

742

Fiber.yield r # exit step method

743

else

744

@c_stack[1].resume r # resume call_sub method with r

745

end

746

end

747

end

748


749

def self.read str

750

str = str.lstrip

751

if str[0, 2] == "(\\" then

752

str = str[2 .. 1]

753

lst, str = read_list str

754

node = ProgNode.new

755

params = []

756

p = lst.car

757

while p != RDMNil::Nil do

758

params << p.car

759

p = p.cdr

760

end

761

node.set_lambda params, lst.cdr

762

[node, str]

763

elsif str[0, 2] == "'(" then

764

str = str[2 .. 1]

765

lst, str = read_list str

766

lst = read_convlist lst

767

[lst, str]

768

elsif str[0] == "(" then

769

str = str[1 .. 1]

770

read_list str

771

elsif str[0] == "\"" then

772

idx = str.index(/[^\\]"/, 1) + 1

773

s = str[1 ... idx]

774

s = s.gsub(/\\/){""} # XXX

775

[s, str[idx + 1 .. 1]]

776

elsif m = /\A([09]+)/.match(str) then

777

s = m[1]

778

str = str[s.length .. 1]

779

[s.to_i, str]

780

elsif m = /\A([!'*+<=>?AZ_az][!'*+09<=>?AZ_az]*)/.match(str) then

781

s = m[1]

782

str = str[s.length .. 1]

783

[s.to_sym, str]

784

else

785

raise "read error: \"#{str}\""

786

end

787

end

788


789

def self.read_list str

790

str = str.lstrip

791

if str[0] == ")" then

792

str = str[1 .. 1]

793

[RDMNil::Nil, str]

794

else

795

val, str = read str

796

cell = RDMCons.new val

797

str = str.lstrip

798

if str[0] == "." then

799

str = str[1 .. 1]

800

val, str = read str

801

str = str.lstrip

802

if str[0] == ")" then

803

str = str[1 .. 1]

804

cell.cdr = val

805

[cell, str]

806

else

807

raise "read error: \"#{str}\""

808

end

809

else

810

val, str = read_list str

811

cell.cdr = val

812

[cell, str]

813

end

814

end

815

end

816


817

def self.read_convlist lst

818

case lst

819

when RDMNil then

820

ProgNode::P_Nil::Nil

821

when RDMCons then

822

ProgNode::P_Cons.new(read_convlist(lst.car), read_convlist(lst.cdr))

823

else

824

lst

825

end

826

end

827


828

# convert lisp sexpression style tree to

829

# ProgNode tree

830

def self.convert exp

831

if exp.kind_of? RDMCons then

832

case exp.cdr

833

when RDMCons then

834

conv_(convert(exp.car), exp.cdr)

835

when RDMNil then

836

convert exp.car

837

else

838

raise

839

end

840

elsif exp.kind_of? ProgNode and exp.tag == :lambda then

841

exp.convert_lambda

842

elsif exp.kind_of? ProgNode

843

raise

844

elsif exp.kind_of? Symbol

845

if ProgNode::SYMNODES.has_key? exp then

846

ProgNode::SYMNODES[exp]

847

else

848

ProgNode.make_dummynode exp

849

end

850

else

851

ProgNode.make_valnode exp

852

end

853

end

854


855

def self.conv_ e, e2

856

n = ProgNode.make_appnode(e, convert(e2.car))

857

case e2.cdr

858

when RDMNil then

859

n

860

else

861

conv_ n, e2.cdr

862

end

863

end

864

end

865


866

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]

867

#puts src.inspect

868

prg = RDM.convert src

869

#puts prg.inspect

870

prg = prg.compile

871

#puts prg.inspect

872


873

intp = RDM::Intp.new

874

#intp.trace_on

875

intp.setup prg

876

begin

877

r = intp.step

878

end until r

879


880

print "result = #{r.val}\n"
