CoffeeScriptでProlog的なことをやってみた

テスト前日なので、

Rubyで作るProlog処理系 （1/2）：CodeZine - http://codezine.jp/article/detail/461

を見てPrologインタープリタ的なのを作って、FizzBuzzしてみた。

prolog.coffee

isSymbol = (t)-> t is t.toUpperCase?()

class Pred
  constructor: (@name) ->
    @defs = []
  is: (args...) ->
    new Goal(@, args)

pred = (x) -> new Pred(x)

class Goal
  constructor: (@pred, @args) ->
  si: (rhs...) ->
    @pred.defs.push([@, list(rhs...)])
  calls: (callback) ->
    @pred.defs.push([@, callback])

class Cons
  constructor: (car, cdr) ->
    [@[0], @[1]] = [car, cdr]

cons = (car, cdr) -> new Cons car, cdr

list = (xs...) -> xs.reduceRight (ls, x) ->
  cons x, ls
, null

class Env
  constructor: ->
    @table = {}
  put: (x, pair) ->
    @table[x] = pair
  get: (x) -> @table[x]
  del: (x) -> delete @table[x]
  clear: ->
    @table = {}
  dereference: (t) ->
    env = @
    while isSymbol t
      p = env.get t
      break unless p
      [t, env] = p
    [t, env]
  item: (t) ->
    [t, env] = @dereference t
    return switch
      when t instanceof Goal then new Goal t.pred, env.item(t.args)
      when t instanceof Cons then cons env.item(t[0], t[1])
      when t instanceof Array then t.map (e) -> env.item(e)
      else t

_unify = (x, xEnv, y, yEnv, trail, tmpEnv) ->
  loop
    if isSymbol x
      xp = xEnv.get x
      unless xp
        [y, yEnv] = yEnv.dereference y
        unless x is y and xEnv is yEnv
          xEnv.put x, [y, yEnv]
          trail.push([x, xEnv]) unless xEnv is tmpEnv
        return true
      else
        [x, xEnv] = xp
        [x, xEnv] = xEnv.dereference x
    else if isSymbol y
      [x, xEnv, y, yEnv] = [y, yEnv, x, xEnv]
    else
      break
  if x instanceof Goal and y instanceof Goal
    return false unless x.pred is y.pred
    [x, y] = [x.args, y.args]
  if x instanceof Array and y instanceof Array
    return false unless x.length is y.length
    for i in [0 ... x.length]
      return false unless _unify(x[i], xEnv, y[i], yEnv, trail, tmpEnv)
    return true
  else
    return x is y

resolve = (goals...) ->
  cb = goals.pop()
  env = new Env
  _resolveBody(list(goals...), env, [false], -> cb env)

_resolveBody = (body, env, cut, cb) ->
  if body is null then cb()
  else
    [goal, rest] = body
    if goal is 'CUT'
      _resolveBody(rest, env, cut, cb)
      cut[0] = true
    else
      dEnv = new Env
      dCut = [false]
      for [dHead, dBody] in goal.pred.defs
        break if dCut[0] or cut[0]
        trail = []
        if _unify(goal, env, dHead, dEnv, trail, dEnv)
          if typeof dBody is 'function'
            if dBody(new CallbackEnv(dEnv, trail))
              _resolveBody(rest, env, cut, cb)
          else
            _resolveBody(dBody, dEnv, dCut, ->
              _resolveBody(rest, env, cut, cb)
              dCut[0] ||= cut[0]
            )
        for [x, xEnv] in trail
          xEnv.del(x)

class CallbackEnv
  constructor: (@env, @trail) ->
  item: (t) -> @env.item(t)
  unify: (t, u) -> _unify(t, @env, u, @env, @trail, @env)

fizzbuzz = pred 'fizzbuzz'
assign = pred 'assign'
show = pred 'show'
eq = pred 'eq'
add = pred 'add'
mod = pred 'mod'
divable = pred 'divable'
print = pred 'print'

runFizzbuzz = pred 'runFizzbuzz'
runFizzbuzz2 = pred 'runFizzbuzz2'

assign.is('A', 'B').calls (env) ->
  env.unify('A', 'B')

show.is('A', 'B').calls (env) ->
  env.unify('A', env.item('B').toString?())

eq.is('A', 'B').calls (env) ->
  env.item('A') is env.item('B')

mod.is('A', 'B', 'X').calls (env) ->
  env.unify('X', env.item('A') % env.item('B'))

add.is('A', 'B', 'X').calls (env) ->
  env.unify('X', env.item('A') + env.item('B'))

print.is('X').calls (env) ->
  console.log env.item('X')
  true

divable.is('A', 'B').si mod.is('A', 'B', 'X'), eq.is('X', 0)

fizzbuzz.is('I', 'fizzbuzzhoge').si divable.is('I', 3), divable.is('I', 5), divable.is('I', 8), 'CUT'
fizzbuzz.is('I', 'buzzhoge').si divable.is('I', 5), divable.is('I', 8), 'CUT'
fizzbuzz.is('I', 'fizzhoge').si divable.is('I', 3), divable.is('I', 8), 'CUT'
fizzbuzz.is('I', 'fizzbuzz').si divable.is('I', 3), divable.is('I', 5), 'CUT'
fizzbuzz.is('I', 'hoge').si divable.is('I', 8), 'CUT'
fizzbuzz.is('I', 'fizz').si divable.is('I', 3), 'CUT'
fizzbuzz.is('I', 'buzz').si divable.is('I', 5), 'CUT'
fizzbuzz.is('I', 'I').si()

runFizzbuzz.is(101).si 'CUT'
runFizzbuzz.is('I').si fizzbuzz.is('I', 'S'), print.is('S'), add.is('I', 1, 'I1'), runFizzbuzz.is('I1')

runFizzbuzz2.is(200, '_').si 'CUT'
runFizzbuzz2.is('I', 'X').si fizzbuzz.is('I', 'X')
runFizzbuzz2.is('I', 'X').si add.is('I', 1, 'I1'), runFizzbuzz2.is('I1', 'X')

resolve runFizzbuzz2.is(1, 'X'), (env) ->
  console.log env.item('X')

特に解説等はしません。
なぜならテスト前日だから。