正規表現嗜好(ネタ)言語 - 作りかけ

al.rb

require "strscan"
require "pp"

##
## Alインタープリター
##

# codes
AlFail = Object.new
AlTrue = Object.new
AlCrop = Struct.new :next
AlGoal = Struct.new :next, :name, :args
AlDisj = Struct.new :choices


class AxValue
	def instantiate(binding)
		self
	end
	
	def to_s
		strip.raw.to_s
	end
	
	def strip
		self
	end
	
	def self.value_compare(lhs, rhs)
		return lhs <=> rhs if lhs.class == rhs.class
		a , b = {AxString => 2, AxRegExp => 1, AxVar => 0}.values_at(lhs.class, rhs.class)
		a - b
	end
end

class AxRegExp < AxValue
	attr_reader :raw, :binding
	
	def initialize(raw, binding)
		@raw     = raw
		@binding = binding
	end
	
	def as_literal
		"{#{@raw.to_s}}"
	end
	
	def inspect
		"AxRegExp(#{@raw}, #{@binding.count})"
	end
end

class AvRegExp

	def initialize(values)
		@values = values
	end

	def instantiate(binding)
		buf = ""
		@values.map {|val|
			if val.is_a? AvVar
				val = val.instantiate(binding).val
				buf << case val
				when AxString then Regexp::quote(val.to_s)
				when AxRegExp then val.raw.to_s
				when AxVar then ""
				end
			else
				buf << val.to_s
			end
		}.join
		AxRegExp.new Regexp.new(buf), binding
	end
	
	def <=>(rhs)
		-1
	end
end

class AxString < AxValue
	attr_reader :raw
	
	def initialize(raw)
		@raw = raw
	end
	
	def as_literal
		'"' + @raw.gsub(/"/, '\\"') + '"'
	end
	
	def <=>(rhs)
		@raw <=> rhs.raw
	end
	
	def inspect
		"AxString(#{@raw})"
	end
end

class AvString
	
	def initialize(values)
		@values = values
	end
	
	def instantiate(binding)
		AxString.new(@values.map {|val| val.instantiate(binding).to_s }.join)
	end
end

class AxVar < AxValue
	attr_accessor :raw, :name, :binding
	
	def initialize(name, binding)
		@name    = name
		@binding = binding
		@raw     = nil
	end
	
	def as_literal
		var = val
		var.is_a?(AxVar) ? "#{var.name}_#{var.binding.count}": var.as_literal
	end
	
	def strip
		val
	end
	
	def val
		raw = @raw
		while raw.is_a? AxVar
			@raw = raw
			 raw = raw.raw
		end
		raw or @raw or self
	end
	
	def val=(val)
		@raw = val
	end
	
	def <=>(rhs)
		a =     binding.count
		b = rhs.binding.count
		(a - b).nonzero? or name <=> rhs.name
	end
	
	def inspect
		"AxVar(#{name}:#{binding.count}, #{raw} => #{val})"
	end
end

class AvVar
	
	def initialize(name)
		@name = name
	end
	
	def instantiate(binding)
		binding[@name]
	end
end

class AlBinding
	attr_reader :count, :prev, :code, :vars, :depth
	
	def initialize(count, prev, code)
		@count = count
		@depth = (@prev = prev) ? prev.depth + 1: 0
		@code = code
		@vars = {}
	end
	
	def [](name)
		@vars[name] ||= AxVar.new(name, self)
	end
end

class AlChoicePoint
	attr_accessor :vars, :count, :binding, :choices
	
	def initialize(count, binding, choices)
		@count = count
		@binding = binding
		@choices = choices
		@vars = []
	end
	
end

class AlState
	
	def initialize
		@db = {}
		AlRule::FOREIGN_RULES.each {|name, rule|
			self[name] << rule
		}
		
		# マッチ演算子を定義
		parse "= X, X."
	end
	
	def [](name, arity=nil)
		@db[arity ? "#{name}/#{arity}": name] ||= []
	end
	
	def parse(script)
		reader = AlReader.new script
		parser = AlParser.new reader
		while clause = parser.next_clause
			#p clause
			case clause.kind
			when ":-"
				name = clause.values[0]
				args = clause.values[1]
				args = args.map {|arg| AlState.compile arg }
				rows = self[name, args.size]
				rows << AlRule.new(clause.values[2] && AlState.compile(clause.values[2]) || AlTrue, name, args)
			when "?-"
				AlQuery.new(AlState.compile clause.values[2]).ask
			else
				raise "(*_*) bug? #{node.inspect}"
			end
		end
	end
	
	def new_query(script)
		reader = AlReader.new script
		parser = AlParser.new reader
		AlQuery.new self, AlState.compile(parser.next_body)
	end
	
	def self.compile(node, succ=AlTrue, list=nil)
		code = case node.kind
		when ";" then
			if list
				compile node.values[0], succ, list
				compile node.values[1], succ, list
				return
			end
			list = []
			compile node.values[0], succ, list
			compile node.values[1], succ, list
			return AlDisj.new list
		when "," then
			compile(node.values[0],
			compile(node.values[1], succ))
			
		when "goal" then
			node.values == ["!", []] ?
				AlCrop.new(succ) :
				AlGoal.new(succ,
						node.values[0],
						node.values[1].map {|arg| compile arg })
		# first class objects...
		when "string" then AvString.new extract_vars(node.values[0],  true)
		when "regexp" then AvRegExp.new extract_vars(node.values[0], false)
		when "var" then
			AvVar.new node.values[0]
		else
			raise "(*_*) bug? #{node}"
		end
		list << code if list
		code
	end
	
	def self.extract_vars(literal, unquote)
		a = []
		literal.scan(/((?:\\.|.)*?)(?:\$(?:(\w+)|\{\s*(\w+)\s*})|\z)/) {|data, alt1, alt2|
			if unquote
				data = data.gsub(/\\(.)/) {
					case $1
					when  "n"; "\n"
					when  "r"; "\r"
					when  "t"; "\t"
					when "\\"; "\\"
					else $1
					end
				}
			end
			a << AxString.new(data) if data != ""
			if name = alt1 || alt2
				a << AvVar.new(name)
			end
		}
		a
	end
end

class AlQuery
	attr_reader :state, :stack
	
	def initialize(state, code)
		@state   = state
		@stack   = []
		@code    = code
		@counter = 1
		@binding = AlBinding.new 1, nil, nil
	end
	
	def empty?
		@stack.empty?
	end
	
	def ask
		loop {
			while @code == AlFail
				return nil if empty?
				choice_point = @stack.last
				choice_point.vars.each {|var| var.raw = nil }
				choice_point.vars.clear
				
				@binding = choice_point.binding
				q, @code = choice_point.choices[]
				if q
					@stack.pop
				end
			end
			# p ["next code:", @code.class]
			@code = case @code
			when AlGoal then
				1.times {
					name = @code.name
					args = @code.args.map {|arg| arg.instantiate(@binding).strip }
					succ = @code.next
					rows = state[name, args.size]
					# $stderr.puts "  " * @binding.depth + "call:#{name}(#{args.map(&:as_literal).join ","})"
					if rows.empty?
						raise "existence_error: #{name}/#{args.size}"
					end
					count = @counter
					if rows.size > 1
						i = 1
						set_choice_point(count + 1) {
							@counter = count
							e = rows[i]
							[(i += 1) >= rows.size, invoke(e, args, succ)]
						}
					end
					break invoke(rows[0], args, succ)
				}
			when AlDisj then
				1.times {
					a = @code.choices
					i = 1
					set_choice_point {
						e = a[i]
						[(i += 1) >= a.size, e]
					}
				}
				@code.choices[0]
			when AlTrue then
				unless @binding.prev
					@code = AlFail
					return Hash[* @binding.vars.values.flat_map {|var| [var.name, var.val] }]
				end
				@code    = @binding.code
				@binding = @binding.prev
				@code
			when AlCrop then
				vars = []
				until @stack.empty? or @stack.last.count < @binding.count
					choice_point = @stack.pop
					choice_point.vars.each {|var|
						vars << var if var.binding.count >= @binding.count
					}
				end
				@stack.last.vars.concat vars unless @stack.empty?
				@code.next
			else
				raise "(*_*) ??? #{@code.inspect}"
			end
		}
	end
	
	def set_choice_point(count=@binding.count, &choices)
		@stack << AlChoicePoint.new(count, @binding, choices)
	end
	
	def invoke(procedure, args, code)
		procedure.perform(self, args,
			@binding = AlBinding.new(@counter += 1, @binding, code))
	end

end

class AlMatcher
	
	def initialize
		@tmpbuf = {}
	end
	
	def exec(x, y)
		result = match x, y
		# p ["match(#{result}):", x.strip, y.strip]
		result
	end
	
	def match(x, y)
		return true if x.object_id == y.object_id
		x = deref x
		y = deref y
		case [x.class, y.class]
		when [AxVar, AxVar] then
			relation = x <=> y
			case
			when relation < 0 then substitute(y, x)
			when relation > 0 then substitute(x, y)
			end
			true
		when [AxString, AxString] then x.raw == y.raw
		when [AxRegExp, AxRegExp] then raise "cannot match `RegExp' with `RegExp'!"
		when [AxString, AxRegExp] then match_rx(y, x)
		when [AxRegExp, AxString] then match_rx(x, y)
		else
			x.is_a?(AxVar) ?
				substitute(x, y) :
				substitute(y, x)
			true
		end
	end
	
	def commit(query)
		choice_point = query.stack.last
		@tmpbuf.each {|var, val|
			choice_point.vars << var if choice_point
			var.val = val
		}
	end
	
	def substitute(var, val)
		@tmpbuf[var] = val
	end
	
	def match_rx(rx, val)
		return nil unless data = rx.raw.match(val.to_s)
		data.names.all? {|name|
			match(rx.binding[name], AxString.new(data[name]))
		}
	end
	
	def deref(val)
		while val.is_a?(AxVar) and (var = @tmpbuf[val] || val.val) != val
			val = var
		end
		val
	end
end

class AlRule
	
	def initialize(code, name=nil, args=nil)
		@name = name
		@args = args
		@code = code
	end
	
	def perform(query, args, binding)
		#p ["perform!!", args.map {|a| a.strip}]
		matcher = AlMatcher.new
		if args.zip(@args).all? {|x, y| matcher.exec(x, y.instantiate(binding)) }
			matcher.commit query
			return @code
		end
		AlFail
	end
	
	# built-in rules
	FOREIGN_RULES = []
	
	class AlForeignRule
		
		def initialize(exec)
			@exec = exec
		end
		
		def perform(query, args, binding)
			@exec[query, args, binding]
		end
	end
	
	def self.def_rule(name, &exec)
		FOREIGN_RULES << [name, AlForeignRule.new(exec)]
	end
	
	def_rule("eval/1") {|query, args, binding|
		script = args[0]
		if script.is_a?(AxString)
			raise "type_error: #{script.inspect}"
		end
		reader = AlReader.new script
		parser = AlParser.new reader
		AlState.compile(parser.next_body)
	}
	
	def_rule("puts/1") {|query, args, binding|
		print args[0]
		AlTrue
	}
	
	def_rule("gets/1") {|query, args, binding|
		AlGoal.new(AlTrue, "=", [args[0], AxString.new($stdin.gets)])
	}
	
	def_rule("halt/0") {|query, args, binding|
		exit
	}
	
	def_rule( "</2") {|query, args, binding| AxValue.value_compare(*args)  < 0 ? AlTrue: AlFail }
	def_rule( ">/2") {|query, args, binding| AxValue.value_compare(*args)  > 0 ? AlTrue: AlFail }
	def_rule("==/2") {|query, args, binding| AxValue.value_compare(*args) == 0 ? AlTrue: AlFail }

end


##
## 構文解析と字句解析
##

AlNode = Struct.new :kind, :values
AlNone = AlNode.new "none"

class AlParser
	
	def initialize(l)
		@l = l
	end
	
	def next_clause
		
		# end of stream
		return nil if @l.head == AlNone
		
		# query "?- XXX."
		if @l.head.kind == "?-"
			@l.walk
			return AlNode.new "?-", next_body
		end
		
		# rule "XXX(XXX, ...) :- XXX."
		name = expect("sym").values[0]
		args = []
		unless %w[:- .].include? @l.head.kind
			args = next_args
			raise "expected `:-' or `.', but `#{@l.head}' found." unless %w[:- .].include? @l.head.kind
		end
		if @l.walk.kind == "."
			return AlNode.new(":-", [name, args, nil])
		end
		rule = AlNode.new(":-", [name, args, next_body])
		expect "."
		rule
	end
	
	def next_args
		args = []
		loop {
			break unless is_first_class arg = @l.walk
			args << arg
			break if @l.head.kind != ","
			@l.walk
		}
		args
	end
	
	def next_body
		next_infix_colon
	end
	
	def next_infix_colon()
		lhs = next_infix_comma
		lhs = AlNode.new ";", [lhs, next_infix_comma] while @l.head.kind == ";" and @l.walk
		lhs
	end
	
	def next_infix_comma()
		lhs = next_infix_equal
		lhs = AlNode.new ",", [lhs, next_infix_equal] while @l.head.kind == "," and @l.walk
		lhs
	end
	
	def next_infix_equal()
		if is_first_class @l.head
			lhs = @l.walk
			mid = @l.walk
			rhs = @l.walk
			unless is_first_class rhs
				raise "expected FIRST_CLASS"
			end
			return AlNode.new "goal", [mid.values[0], [lhs, rhs]] 
		end
		next_goal
	end
	
	def next_goal()
		return case ( name = @l.walk ).kind
		when "sym" then
			args = []
			if @l.head.kind == '('
				@l.walk
				args = next_args
				expect ")"
			end
			AlNode.new "goal", [name.values[0], args]
		when "(" then
			node = next_body
			expect ")"
			node
		else
			raise "expected GOAL"
		end
	end
	
	def expect(kind)
		l = @l.walk
		raise "expected `#{kind}', but `#{l}' found." if l.kind != kind
		l
	end
	
	def is_first_class(l)
		["var", "regexp", "string"].include? l.kind
	end
end

class AlReader
	attr_reader :head
	
	def initialize(s)
		@s = StringScanner.new s
		def @s.*(rhs)
			scan rhs
		end
		walk
	end
	
	def walk
		ahead = @head
		@head = get_next
		ahead
	end
	
	def get_next
		@s * /^(\s*(\/\*.*?\*\/|%.*?$))*\s*/m
		case
		when @s *     /^"((?:\\.|.)*?)"/; return AlNode.new "string", [@s[1]]
		when @s *   /^(?:[().,;]|[:?]-)/; return AlNode.new @s[0]
		when @s *    /^(?:[A-Z].*?|_)\b/; return AlNode.new "var", [@s[0]]
		when @s *           /^[\w=<>!]+/; return AlNode.new "sym", [@s[0]]
		end
		if @s * /^\{/
			balance = 1
			pos = @s.pos
			while @s * /^(?:\\.|.)*?([{}])/
				return AlNode.new("regexp", [@s.string[pos...(@s.pos-1)]]) if
						(balance += @s[1] == '}' ? -1: +1) == 0
			end
			raise "unbalanced `{' (^_^;) `}'"
		end
		AlNone
	end
	
end


##
## メイン
##

if ARGV.empty?
	puts "usage:ruby al.rb SCRIPTFILE"
	exit -1
end

$stderr.puts <<"MSG"
AL language shell 0.1
MSG

state = AlState.new
state.parse File.read(ARGV[0])

loop {
	$stderr.print "\n> "
	$stderr.flush
	query = state.new_query $stdin.gets
	loop {
		if answer = query.ask
			answer.each {|var, val|
				$stderr.puts "#{var} = #{val.as_literal}"
			}
			if !query.empty?
				$stderr.print "[y/N]"
				$stderr.flush
				next if $stdin.gets !~/y/
			end
			puts "!true!"
		else
			puts "!fail!"
		end
		break
	}
}