Project

General

Profile

Bug #3781 » reduct.rb

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

 
1
# coding:utf-8
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([0-9]+)/.match(str) then
777
			s = m[1]
778
			str = str[s.length .. -1]
779
			[s.to_i, str]
780
		elsif m = /\A([-!'*+<=>?A-Z_a-z][-!'*+0-9<=>?A-Z_a-z]*)/.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 s-expression 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"