Lua で作った flyweight な tuple の実装

tuple.lua

-- tuple.lua
-- 簡潔なタプルの実装
-- 特徴：
--   ・immutable
--     タプルの各要素は完全に immutable である
--     というより、関数として実装されているので変更しようがない
--   ・flyweight
--     tuple.new(...) で得られたオブジェクトが生き残っている限り、
--     常に tuple.new( ... ) == tuple.new( ... ) が成立する。
--     テーブルのキーとして使ったときに同一性を保証できる。
--   ・nilを含められる
--     タプル中に任意に nil を含められる。

local G = getfenv()

module(...)

local tuple_data = { __mode = "k" }
G.setmetatable( tuple_data, tuple_data )

local cons_
do
  local error = G.error
  local assert = G.assert
  
  function nil_(x)
    if x == nil then
      return
    elseif x == '#' then
      return 0
    elseif x >= 1 then
      return
    else
      error "index out of range"
    end
  end
  local nil_ = nil_
  tuple_data[nil_] = function () return nil, nil_ end
  
  function cons_( car, cdr )
    if cdr ~= nil_ then
      local n = cdr('#') + 1
      return function(x)
        if x == nil then
          return car, cdr()
        elseif x == '#' then
          return n
        elseif x >= 2 then
          return cdr( x - 1 )
        elseif x >= 1 then
          return car, cdr()
        elseif x >= 0 then
          error "index out of range"
        else
          x = x + n
          if x >= 1 then
            return cdr( x )
          elseif x >= 0 then
            return car, cdr()
          else
            error "index out of range"
          end
          return car, cdr()
        end
      end
    else
      return function(x)
        if x == nil then
          return car
        elseif x == '#' then
          return 1
        elseif x >= 2 then
          return
        elseif x >= 1 then
          return car
        elseif x >= 0 then
          error "index out of range"
        elseif x >= -1 then
          return car
        else
          error "index out of range"
        end
      end
    end
  end
end
local nil_ = nil_

do
  local mt = { __mode = "kv" }
  local tuples = {}
  local function nil_tag() end
  
  local setmetatable = G.setmetatable
  setmetatable( tuples, mt )
  
  function cons( car, cdr )
    local key = car
    if key == nil then
      key = nil_tag
    end
    local cdr = cdr or nil_
    
    local t = tuples[key]
    if t ~= nil then
      local tuple = t[cdr]
      if tuple ~= nil then
        return tuple
      end
    else
      t = {}
      setmetatable( t, mt )
      tuples[key] = t
    end
    
    local tuple = cons_( car, cdr )
    t[cdr] = tuple
    tuple_data[tuple] = function ()
      do return car, cdr end
      local bind = t  -- bind t
    end
    return tuple
  end
  
  -- enumerate tuples ( for test )
  local pairs = G.pairs
  function enum_tuples_()
    local result = {}
    local n = 0
    
    for _, cdrs in pairs(tuples) do
      for _, tuple in pairs(cdrs) do
        n = n + 1
        result[n] = tuple
      end
    end
    
    return result
  end
end

-- make tuple
do
  local cons = cons
  
  local select = G.select
  function new( ... )
    local cdr = nil_
    for i = select('#', ... ), 1, -1 do
      local car = select( i, ... )
      cdr = cons( car, cdr )
    end
    return cdr
  end
end

-- utility functions
do
  local assert = G.assert
  
  function is_tuple(t)
    local data = tuple_data[t]
    return data ~= nil
  end
  local is_tuple = is_tuple
  
  function uncons(t)
    assert( t ~= nil_, "attempt to uncons nil_" )
    local data = assert( tuple_data[t], "bad arugument #1 to 'uncons' (tuple expected)" )
    local car, cdr = data()
    return car, cdr
  end
  
  function car(t)
    if t == nil_ then return end
    local data = assert( tuple_data[t], "bad arugument #1 to 'car' (tuple expected)" )
    local car, cdr = data()
    return car
  end
  function cdr(t)
    local data = assert( tuple_data[t], "bad arugument #1 to 'cdr' (tuple expected)" )
    local car, cdr = data()
    return cdr
  end
  
  function len(t)
    assert( is_tuple(t), "bad arugument #1 to 'len' (tuple expected)" )
    return t("#")
  end
  
  function select( t, x )
    assert( is_tuple(t), "bad arugument #1 to 'select' (tuple expected)" )
    return t(x)
  end
  
end

tuple_test.lua

-- tuple の実装テスト

require "tuple"

-- デバッグ用の部品
do
  local traceback = debug.traceback
  local tests = 0
  local failed = 0
  
  function check( cond )
    tests = tests + 1
    
    if not cond then
      print( traceback( "check " .. tests .. " failed.", 2 ) .. "\n" )
      failed = failed + 1
    end
  end
  
  function print_resuts()
    print( "tests:", tests )
    
    if failed == 0 then
      print "all tests passed."
    else
      print( "failed:", failed )
    end
  end
end
local check = check
local print_resuts = print_resuts


-- 本体

local tuple = tuple

local select = select
local function check_tuple(t)
  check( tuple.is_tuple(t) )
  
  -- equality check
  check( t == tuple.new( t() ) )
  do
    local cdr = t
    while cdr ~= tuple.nil_ do
      cdr = tuple.cdr(cdr)
      check( cdr == tuple.new( cdr() ) )
    end
  end
  
  -- length check
  local len = select( '#', t() )
  check( t('#') == len )
  check( tuple.len(t) == len )
  check( tuple.select(t, '#') == len )
  
  if len ~= 0 then
    -- car/cdr
    local car, cdr = tuple.uncons(t)
    check( tuple.car( t ) == car )
    check( tuple.cdr( t ) == cdr )
    check( tuple.cons( car, cdr ) == t )
    
    local x1 = t(1)
    check( car == x1 )
    
    -- elements
    for i = 1, len do
      local x1 = t(i)
      
      local x2 = tuple.select( t, i )
      check( x2 == x1 )
      local x3 = select( i, t() )
      check( x3 == x1 )
      
      local j = i - 1 - len
      
      local x4 = t( j )
      check( x4 == x1 )
      local x5 = tuple.select( t, j )
      check( x5 == x1 )
      local x6 = select( j, t() )
      check( x6 == x1 )
    end
    
    -- i, i > len
    for i = len+1, len*2 do
      check( select( '#', t(i) ) == 0 )
      check( select( '#', tuple.select( t, i ) ) == 0 )
    end
  else
    check( t == tuple.nil_ )
    check( select( '#', tuple.car(t) ) == 0 )
    check( tuple.cdr(t) == tuple.nil_ )
  end
end

check_tuple( tuple.new() )
check_tuple( tuple.new( 1, 2 ) )
check_tuple( tuple.new( {}, function () end ) )

-- long tuple
local unpack = unpack
do
  local t = {}
  for i = 1, 512 do
    t[i] = {}
  end
  
  check_tuple( tuple.new( unpack(t) ) )
end

-- release check
local setmetatable = setmetatable
local rand = math.random
local collectgarbage = collectgarbage
do
  local t = {}
  local n = 128
  
  local not_released = tuple.new(
    "a", {}, function() end, "x"
  )
  check_tuple( not_released )
  
  for i = 1, n do
    local ns = {}
    for i = 1, 10 do
      ns[i] = rand(10)
    end
    
    t[i] = tuple.new( unpack(ns) )
    check_tuple( t[i] )
  end
  
  local ipairs = ipairs
  local function count_elems(t)
    local n = 0
    for _, _ in ipairs(t) do
      n = n + 1
    end
    return n
  end
  
  check( count_elems(t) == n )
  
  -- set t to weak
  setmetatable( t, { __mode = "kv" } )
  
  -- garbage collection
  repeat
    local n_old = n
    
    collectgarbage()
    n = count_elems(t)
  until n_old == n
  
  -- GC has done.
  check( n == 0 )
  
  -- check not released
  check_tuple( not_released )
end

print_resuts()

タプルを作ったと思ったらリストだったでござるの巻。

ユーティリティ関数にタプルか否かのチェックを追加。
それに伴い、侵入的な car, cdr 処理を排除し、より高速に unpack 出来るように。

テストケースを追加、ちゃんとメモリが解放されているらしいことを確認。