Project

General

Profile

Bug #3781 » reduct.rb

2011/Aug/24 - metanest (Makoto Kishimoto), 08/24/2011 09:36 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
GC.stress = true
16

    
17
require "fiber"
18

    
19
module RDM
20
	class RDMList
21
		private_class_method :new
22

    
23
		def inspect
24
			"(#{inspect_}"
25
		end
26

    
27
		def inspect_
28
			case self
29
			when RDMNil then
30
				")"
31
			when RDMCons then
32
				@car.inspect +
33
				case @cdr
34
				when RDMNil then
35
					@cdr.inspect_
36
				when RDMCons then
37
					" #{@cdr.inspect_}"
38
				else
39
					" . #{@cdr.inspect})"
40
				end
41
			else
42
				raise
43
			end
44
		end
45
	end
46

    
47
	class RDMNil < RDMList
48
		Nil = new
49
	end
50

    
51
	class RDMCons < RDMList
52
		public_class_method :new
53

    
54
		attr_accessor :car, :cdr
55

    
56
		def initialize car=RDMNil::Nil, cdr=RDMNil::Nil
57
			@car, @cdr = car, cdr
58
		end
59
	end
60

    
61
	class ProgNode
62
		class P_List
63
			private_class_method :new
64

    
65
			def inspect cache={}
66
				if !self.kind_of? P_Nil and  cache.has_key? self then
67
					return "[...]"
68
				end
69
				cache[self] = true
70
				"[#{inspect_ cache}"
71
			end
72

    
73
			def inspect_ cache
74
				case self
75
				when P_Nil then
76
					"]"
77
				when P_Cons then
78
					case @car
79
					when P_List then
80
						@car.inspect(cache)
81
					else
82
						@car.inspect
83
					end +
84
					case @cdr
85
					when P_Nil then
86
						@cdr.inspect_ cache
87
					when P_Cons then
88
						", #{@cdr.inspect_ cache}"
89
					else
90
						" . #{@cdr.inspect}]"
91
					end
92
				else
93
					raise
94
				end
95
			end
96
		end
97

    
98
		class P_Nil < P_List
99
			Nil = new
100
		end
101

    
102
		class P_Cons < P_List
103
			public_class_method :new
104

    
105
			attr_reader :car, :cdr
106

    
107
			def initialize a, d
108
				@car = a
109
				@cdr = d
110
			end
111
		end
112

    
113
		attr_reader :tag
114

    
115
		def initialize
116
			@tag = :undefined
117
		end
118

    
119
		def clear_instance_variables
120
			instance_variables.each {|name|
121
				remove_instance_variable name
122
			}
123
		end
124

    
125
		def replace that
126
			unless equal? that then
127
				clear_instance_variables
128
				that.instance_variables.each {|name|
129
					instance_variable_set(name, that.instance_variable_get(name))
130
				}
131
			end
132
			nil
133
		end
134

    
135
		def set_app fun, arg, &c
136
			clear_instance_variables
137
			@tag = :app
138
			@car = fun
139
			@cdr = arg
140
			@proc = c
141
		end
142

    
143
		def set_val val, &c
144
			clear_instance_variables
145
			@tag = :val
146
			@val = val
147
			@proc = c
148
		end
149

    
150
		def set_lambda params, exp
151
			clear_instance_variables
152
			@tag = :lambda
153
			@params = params
154
			@exp = exp
155
		end
156

    
157
		def convert_lambda
158
			n = ProgNode.new
159
			n.set_lambda(@params, RDM.convert(@exp))
160
			n
161
		end
162

    
163
		def car
164
			unless @tag == :app then
165
				return nil
166
			end
167
			@car
168
		end
169

    
170
		def cdr
171
			unless @tag == :app then
172
				return nil
173
			end
174
			@cdr
175
		end
176

    
177
		def val
178
			unless @tag == :val then
179
				return nil
180
			end
181
			@val
182
		end
183

    
184
		def method_missing name, *args
185
			if m = /\Ac([ad]*)r\z/.match(name.to_s) then
186
				if args.empty? then
187
					p = self
188
					m[1].reverse.each_char {|c|
189
						case c
190
						when "a" then
191
							p = p.car
192
						when "d" then
193
							p = p.cdr
194
						end
195
						unless p then
196
							return p
197
						end
198
					}
199
					p
200
				else
201
					super
202
				end
203
			end
204
		end
205

    
206
		def inspect reminder={}
207
			case @tag
208
			when :val then
209
				@val.inspect
210
			when :app then
211
				"(#{inspect_app reminder})"
212
			when :lambda then
213
				"{#{@params.inspect} #{@exp.inspect}}"
214
			end
215
		end
216

    
217
		def inspect_app reminder
218
			if reminder.has_key? self then
219
				return "..."
220
			end
221
			if @tag == :app then
222
				reminder[self] = true
223
				"#{@car.inspect_app reminder} #{@cdr.inspect reminder}"
224
			else
225
				inspect
226
			end
227
		end
228

    
229
		def compile
230
			case @tag
231
			when :val then
232
				self
233
			when :app then
234
				a = @car.compile
235
				d = @cdr.compile
236
				ProgNode.make_appnode a, d
237
			when :lambda then
238
				e = @exp.compile
239
				@params.reverse.each {|param|
240
					e = e.abstract param
241
				}
242
				e
243
			else
244
				raise
245
			end
246
		end
247

    
248
		def abstract param
249
			case @tag
250
			when :val then
251
				if @val == param then
252
					SYMNODES[:I]
253
				else
254
					ProgNode.make_appnode SYMNODES[:K], self
255
				end
256
			when :app then
257
				a = @car.abstract param
258
				d = @cdr.abstract param
259
				prg = ProgNode.make_appnode SYMNODES[:S], a
260
				prg = ProgNode.make_appnode prg, d
261
				prg.simplify
262
			else
263
				raise
264
			end
265
		end
266

    
267
		def simplify
268
			exp = self
269
			stk = []
270
			e = exp
271
			while e.tag == :app do
272
				stk.push e
273
				e = e.car
274
			end
275
			if (stk.size < 2) or stk[-1].car.val != :S then
276
				return exp
277
			end
278
			# S (K p) (K q)  ==>  K (p q)
279
			if stk[-1].cdr.tag == :app and
280
				stk[-1].cadr.val == :K and
281
				stk[-2].cdr.tag == :app and
282
				stk[-2].cadr.val == :K then
283

    
284
				p = stk[-1].cddr
285
				q = stk[-2].cddr
286
				p_q = ProgNode.make_appnode p, q
287
				e = ProgNode.make_appnode SYMNODES[:K], p_q
288
				return simplify_sub stk, e
289
			# S (K p) I  ==>  p
290
			elsif stk[-1].cdr.tag == :app and
291
				stk[-1].cadr.val == :K and
292
				stk[-2].cdr.val == :I then
293

    
294
				e = stk[-1].cddr
295
				return simplify_sub stk, e
296
			# S (K p) (B q r)  ==>  B* p q r
297
			elsif stk[-1].cdr.tag == :app and
298
				stk[-1].cadr.val == :K and
299
				stk[-2].cdr.tag == :app and
300
				stk[-2].cadr.tag == :app and
301
				stk[-2].caadr.val == :B then
302

    
303
				p = stk[-1].cddr
304
				q = stk[-2].cdadr
305
				r = stk[-2].cddr
306
				e = ProgNode.make_appnode SYMNODES[:"B*"], p
307
				e = ProgNode.make_appnode e, q
308
				e = ProgNode.make_appnode e, r
309
				return simplify_sub stk, e
310
			# S (K p) q  ==>  B p q
311
			elsif stk[-1].cdr.tag == :app and
312
				stk[-1].cadr.val == :K then
313

    
314
				p = stk[-1].cddr
315
				q = stk[-2].cdr
316
				e = ProgNode.make_appnode SYMNODES[:B], p
317
				e = ProgNode.make_appnode e, q
318
				return simplify_sub stk, e
319
			# S (B p q) (K r)  ==>  C' p q r
320
			elsif stk[-1].cdr.tag == :app and
321
				stk[-1].cadr.tag == :app and
322
				stk[-1].caadr.val == :B and
323
				stk[-2].cdr.tag == :app and
324
				stk[-2].cadr.val == :K then
325

    
326
				p = stk[-1].cdadr
327
				q = stk[-1].cddr
328
				r = stk[-2].cddr
329
				e = ProgNode.make_appnode SYMNODES[:"C'"], p
330
				e = ProgNode.make_appnode e, q
331
				e = ProgNode.make_appnode e, r
332
				return simplify_sub stk, e
333
			# S p (K q)  ==>  C p q
334
			elsif stk[-2].cdr.tag == :app and
335
				stk[-2].cadr.val == :K then
336

    
337
				p = stk[-1].cdr
338
				q = stk[-2].cddr
339
				e = ProgNode.make_appnode SYMNODES[:C], p
340
				e = ProgNode.make_appnode e, q
341
				return simplify_sub stk, e
342
			# S (B p q) r  ==>  S' p q r
343
			elsif stk[-1].cdr.tag == :app and
344
				stk[-1].cadr.tag == :app and
345
				stk[-1].caadr.val == :B then
346

    
347
				p = stk[-1].cdadr
348
				q = stk[-1].cddr
349
				r = stk[-2].cdr
350
				e = ProgNode.make_appnode SYMNODES[:"S'"], p
351
				e = ProgNode.make_appnode e, q
352
				e = ProgNode.make_appnode e, r
353
				return simplify_sub stk, e
354
			end
355
			exp
356
		end
357

    
358
		def simplify_sub stk, e
359
			p = e
360
			# copy cells of stk[0 ... -2]
361
			stk[0 ... -2].reverse.each {|cell|
362
				p = ProgNode.make_appnode p, cell.cdr
363
			}
364
			p
365
		end
366

    
367
		def do_action intp
368
			intp.instance_eval &@proc
369
		end
370

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

    
373
		def self.make_valnode val
374
			node = new
375
			node.set_val(val){
376
				return_sub
377
			}
378
			node
379
		end
380

    
381
		def self.make_dummynode val
382
			node = new
383
			node.set_val(val){
384
				raise
385
			}
386
			node
387
		end
388

    
389
		def self.make_appnode fun, arg
390
			node = new
391
			node.set_app(fun, arg){
392
				if @debug then
393
					print "step: push car\n"
394
				end
395
				la_push la_tos.car
396
			}
397
			node
398
		end
399

    
400
		SYMNODES = {}
401

    
402
		def self.regist_symnode sym, &c
403
			node = new
404
			node.set_val sym, &c
405
			SYMNODES[sym] = node
406
		end
407

    
408
		regist_symnode(:S){
409
			# S f g x  -->  f x (g x)
410
			if @debug then
411
				puts "step: reduction S"
412
				puts la_bos.inspect
413
			end
414
			la_pop
415
			f = la_pop.cdr
416
			g = la_pop.cdr
417
			target_cell = la_pop
418
			x = target_cell.cdr
419
			f_x = ProgNode.make_appnode f, x
420
			g_x = ProgNode.make_appnode g, x
421
			newnode = ProgNode.make_appnode f_x, g_x
422
			target_cell.replace newnode
423
			la_push target_cell
424
		}
425

    
426
		regist_symnode(:K){
427
			# K x y  -->  x
428
			if @debug then
429
				puts "step: reduction K"
430
				puts la_bos.inspect
431
			end
432
			la_pop
433
			x = la_pop.cdr
434
			target_cell = la_pop
435
			target_cell.replace x
436
			la_push target_cell
437
		}
438

    
439
		regist_symnode(:I){
440
			# I x  -->  x
441
			if @debug then
442
				puts "step: reduction I"
443
				puts la_bos.inspect
444
			end
445
			la_pop
446
			target_cell = la_pop
447
			x = target_cell.cdr
448
			target_cell.replace x
449
			la_push target_cell
450
		}
451

    
452
		regist_symnode(:Y){
453
			# Y f  -->  f (Y f) == f (f (f (...)))
454
			if @debug then
455
				puts "step: reduction Y"
456
				puts la_bos.inspect
457
			end
458
			la_pop
459
			target_cell = la_pop
460
			f = target_cell.cdr
461
			c = ProgNode.make_appnode f, target_cell
462
			target_cell.replace c
463
			la_push target_cell
464
		}
465

    
466
		regist_symnode(:B){
467
			# B f g x  -->  f (g x)
468
			if @debug then
469
				puts "step: reduction B"
470
				puts la_bos.inspect
471
			end
472
			la_pop
473
			f = la_pop.cdr
474
			g = la_pop.cdr
475
			target_cell = la_pop
476
			x = target_cell.cdr
477
			g_x = ProgNode.make_appnode g, x
478
			f_g_x = ProgNode.make_appnode f, g_x
479
			target_cell.replace f_g_x
480
			la_push target_cell
481
		}
482

    
483
		regist_symnode(:C){
484
			# C f g x  -->  f x g
485
			if @debug then
486
				puts "step: reduction C"
487
				puts la_bos.inspect
488
			end
489
			la_pop
490
			f = la_pop.cdr
491
			g = la_pop.cdr
492
			target_cell = la_pop
493
			x = target_cell.cdr
494
			f_x = ProgNode.make_appnode f, x
495
			f_x_g = ProgNode.make_appnode f_x, g
496
			target_cell.replace f_x_g
497
			la_push target_cell
498
		}
499

    
500
		regist_symnode(:"S'"){
501
			# S' c f g x  -->  c (f x) (g x)
502
			if @debug then
503
				puts "step: reduction S'"
504
				puts la_bos.inspect
505
			end
506
			la_pop
507
			c = la_pop.cdr
508
			f = la_pop.cdr
509
			g = la_pop.cdr
510
			target_cell = la_pop
511
			x = target_cell.cdr
512
			f_x = ProgNode.make_appnode f, x
513
			g_x = ProgNode.make_appnode g, x
514
			c_f_x = ProgNode.make_appnode c, f_x
515
			c_f_x_g_x = ProgNode.make_appnode c_f_x, g_x
516
			target_cell.replace c_f_x_g_x
517
			la_push target_cell
518
		}
519

    
520
		regist_symnode(:"B*"){
521
			# B* c f g x  -->  c (f (g x))
522
			if @debug then
523
				puts "step: reduction B*"
524
				puts la_bos.inspect
525
			end
526
			la_pop
527
			c = la_pop.cdr
528
			f = la_pop.cdr
529
			g = la_pop.cdr
530
			target_cell = la_pop
531
			x = target_cell.cdr
532
			g_x = ProgNode.make_appnode g, x
533
			f_g_x = ProgNode.make_appnode f, g_x
534
			c_f_g_x = ProgNode.make_appnode c, f_g_x
535
			target_cell.replace c_f_g_x
536
			la_push target_cell
537
		}
538

    
539
		regist_symnode(:"C'"){
540
			# C' c f g x  -->  c (f x) g
541
			if @debug then
542
				puts "step: reduction C'"
543
				puts la_bos.inspect
544
			end
545
			la_pop
546
			c = la_pop.cdr
547
			f = la_pop.cdr
548
			g = la_pop.cdr
549
			target_cell = la_pop
550
			x = target_cell.cdr
551
			f_x = ProgNode.make_appnode f, x
552
			c_f_x = ProgNode.make_appnode c, f_x
553
			c_f_x_g = ProgNode.make_appnode c_f_x, g
554
			target_cell.replace c_f_x_g
555
			la_push target_cell
556
		}
557

    
558
		regist_symnode(:IF){
559
			# IF c x y  -->  x OR y
560
			if @debug then
561
				puts "step: reduction IF"
562
				puts la_bos.inspect
563
			end
564
			la_pop
565
			c = la_pop.cdr
566
			x = la_pop.cdr
567
			target_cell = la_pop
568
			y = target_cell.cdr
569
			c = call_sub c
570
			if @debug then
571
				puts "return:"
572
				puts target_cell.inspect
573
			end
574
			r = if c.val == 0 then
575
				y
576
			else
577
				x
578
			end
579
			target_cell.replace r
580
			la_push target_cell
581
		}
582

    
583
		regist_symnode(:<=){
584
			# <= x y  -->  0 OR 1
585
			if @debug then
586
				puts "step: reduction <="
587
				puts la_bos.inspect
588
			end
589
			la_pop
590
			x = la_pop.cdr
591
			target_cell = la_pop
592
			y = target_cell.cdr
593
			x = call_sub x
594
			y = call_sub y
595
			if @debug then
596
				puts "return:"
597
				puts target_cell.inspect
598
			end
599
			r = if x.val <= y.val then
600
				1
601
			else
602
				0
603
			end
604
			newnode = ProgNode.make_valnode r
605
			target_cell.replace newnode
606
			la_push target_cell
607
		}
608

    
609
		regist_symnode(:+){
610
			# + x y  -->  (eval x) + (eval y)
611
			if @debug then
612
				puts "step: reduction +"
613
				puts la_bos.inspect
614
			end
615
			la_pop
616
			x = la_pop.cdr
617
			target_cell = la_pop
618
			y = target_cell.cdr
619
			x = call_sub x
620
			y = call_sub y
621
			if @debug then
622
				puts "return:"
623
				puts target_cell.inspect
624
			end
625
			r = x.val + y.val
626
			newnode = ProgNode.make_valnode r
627
			target_cell.replace newnode
628
			la_push target_cell
629
		}
630

    
631
		regist_symnode(:-){
632
			# - x y  -->  (eval x) - (eval y)
633
			if @debug then
634
				puts "step: reduction -"
635
				puts la_bos.inspect
636
			end
637
			la_pop
638
			x = la_pop.cdr
639
			target_cell = la_pop
640
			y = target_cell.cdr
641
			x = call_sub x
642
			y = call_sub y
643
			if @debug then
644
				puts "return:"
645
				puts target_cell.inspect
646
			end
647
			r = x.val - y.val
648
			newnode = ProgNode.make_valnode r
649
			target_cell.replace newnode
650
			la_push target_cell
651
		}
652

    
653
		regist_symnode(:*){
654
			# * x y  -->  (eval x) * (eval y)
655
			if @debug then
656
				puts "step: reduction *"
657
				puts la_bos.inspect
658
			end
659
			la_pop
660
			x = la_pop.cdr
661
			target_cell = la_pop
662
			y = target_cell.cdr
663
			x = call_sub x
664
			y = call_sub y
665
			if @debug then
666
				puts "return:"
667
				puts target_cell.inspect
668
			end
669
			r = x.val * y.val
670
			newnode = ProgNode.make_valnode r
671
			target_cell.replace newnode
672
			la_push target_cell
673
		}
674
	end
675

    
676
	class Intp
677
		attr_accessor :debug
678

    
679
		def initialize
680
			@la_stack = nil  # left ancestors stack
681
			@debug = false
682
			@c_stack = []  # control stack
683
		end
684

    
685
		def trace_on
686
			@debug = true
687
		end
688

    
689
		def trace_off
690
			@debug = true
691
		end
692

    
693
		def la_push x
694
			@la_stack.push x
695
		end
696

    
697
		def la_pop
698
			@la_stack.pop
699
		end
700

    
701
		def la_bos  # bottom of stack
702
			@la_stack[0]
703
		end
704

    
705
		def la_tos  # top of stack
706
			@la_stack[-1]
707
		end
708

    
709
		def la_hasone?
710
			@la_stack.size == 1
711
		end
712

    
713
		def setup exp
714
			@la_stack = [exp]
715
			@c_stack.push(
716
				Fiber.new {
717
					loop {
718
						la_tos.do_action self
719
						Fiber.yield nil
720
					}
721
				}
722
			)
723
		end
724

    
725
		def step
726
			@c_stack[-1].resume
727
		end
728

    
729
		def call_sub exp
730
 			if @debug then
731
				puts "call:"
732
				puts exp.inspect
733
			end
734
			@c_stack.push @la_stack
735
			setup exp
736
			Fiber.yield nil
737
		end
738

    
739
		def return_sub
740
			r = la_pop
741
			@c_stack.pop
742
			@la_stack = @c_stack.pop
743
			if @c_stack.empty? then
744
				Fiber.yield r  # exit step method
745
			else
746
				@c_stack[-1].resume r  # resume call_sub method with r
747
			end
748
		end
749
	end
750

    
751
	def self.read str
752
		str = str.lstrip
753
		if str[0, 2] == "(\\" then
754
			str = str[2 .. -1]
755
			lst, str = read_list str
756
			node = ProgNode.new
757
			params = []
758
			p = lst.car
759
			while p != RDMNil::Nil do
760
				params << p.car
761
				p = p.cdr
762
			end
763
			node.set_lambda params, lst.cdr
764
			[node, str]
765
		elsif str[0, 2] == "'(" then
766
			str = str[2 .. -1]
767
			lst, str = read_list str
768
			lst = read_convlist lst
769
			[lst, str]
770
		elsif str[0] == "(" then
771
			str = str[1 .. -1]
772
			read_list str
773
		elsif str[0] == "\"" then
774
			idx = str.index(/[^\\]"/, 1) + 1
775
			s = str[1 ... idx]
776
			s = s.gsub(/\\/){""}  # XXX
777
			[s, str[idx + 1 .. -1]]
778
		elsif m = /\A([0-9]+)/.match(str) then
779
			s = m[1]
780
			str = str[s.length .. -1]
781
			[s.to_i, str]
782
		elsif m = /\A([-!'*+<=>?A-Z_a-z][-!'*+0-9<=>?A-Z_a-z]*)/.match(str) then
783
			s = m[1]
784
			str = str[s.length .. -1]
785
			[s.to_sym, str]
786
		else
787
			raise "read error: \"#{str}\""
788
		end
789
	end
790

    
791
	def self.read_list str
792
		str = str.lstrip
793
		if str[0] == ")" then
794
			str = str[1 .. -1]
795
			[RDMNil::Nil, str]
796
		else
797
			val, str = read str
798
			cell = RDMCons.new val
799
			str = str.lstrip
800
			if str[0] == "." then
801
				str = str[1 .. -1]
802
				val, str = read str
803
				str = str.lstrip
804
				if str[0] == ")" then
805
					str = str[1 .. -1]
806
					cell.cdr = val
807
					[cell, str]
808
				else
809
					raise "read error: \"#{str}\""
810
				end
811
			else
812
				val, str = read_list str
813
				cell.cdr = val
814
				[cell, str]
815
			end
816
		end
817
	end
818

    
819
	def self.read_convlist lst
820
		case lst
821
		when RDMNil then
822
			ProgNode::P_Nil::Nil
823
		when RDMCons then
824
			ProgNode::P_Cons.new(read_convlist(lst.car), read_convlist(lst.cdr))
825
		else
826
			lst
827
		end
828
	end
829

    
830
	# convert lisp s-expression style tree to
831
	# ProgNode tree
832
	def self.convert exp
833
		if exp.kind_of? RDMCons then
834
			case exp.cdr
835
			when RDMCons then
836
				conv_(convert(exp.car), exp.cdr)
837
			when RDMNil then
838
				convert exp.car
839
			else
840
				raise
841
			end
842
		elsif exp.kind_of? ProgNode and exp.tag == :lambda then
843
			exp.convert_lambda
844
		elsif exp.kind_of? ProgNode
845
			raise
846
		elsif exp.kind_of? Symbol
847
			if ProgNode::SYMNODES.has_key? exp then
848
				ProgNode::SYMNODES[exp]
849
			else
850
				ProgNode.make_dummynode exp
851
			end
852
		else
853
			ProgNode.make_valnode exp
854
		end
855
	end
856

    
857
	def self.conv_ e, e2
858
		n = ProgNode.make_appnode(e, convert(e2.car))
859
		case e2.cdr
860
		when RDMNil then
861
			n
862
		else
863
			conv_ n, e2.cdr
864
		end
865
	end
866
end
867

    
868
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]
869
#puts src.inspect
870
prg = RDM.convert src
871
#puts prg.inspect
872
prg = prg.compile
873
#puts prg.inspect
874

    
875
intp = RDM::Intp.new
876
#intp.trace_on
877
intp.setup prg
878
begin
879
	r = intp.step
880
end until r
881

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