赤黒木同士の非破壊 JOIN 関数

2 本の赤黒木を左右のどちらかに非破壊で連結した新しい赤黒木を求める JOIN 関数を、 Guy E. Blelloch, et. al., Just Join for Parallel Ordered Sets (2016) に基づいて書いてみます。 ただし、 元論文から安直化してシングルスレッド用の関数を書くことにします。

#!/usr/bin/env ruby
#@<赤黒木クラス@>

class Redblacktree
  def example()
    p join(NULL, 1, NULL)                               #=> ([] 1 [])
    p join(join(NULL, 1, NULL), 2, NULL)                #=> [([] 1 []) 2 []]
    p join(NULL, 1, join(NULL, 2, NULL))                #=> [[] 1 ([] 2 [])]
    p join(join(join(NULL, 1, NULL), 2, NULL), 3, NULL) #=> [([] 1 []) 2 ([] 3 [])]
    p join(join(NULL, 1, join(NULL, 2, NULL)), 3, NULL) #=> ([[] 1 []] 2 [[] 3 []])
    p join(join(NULL, 1, NULL), 2, join(NULL, 3, NULL)) #=> [([] 1 []) 2 ([] 3 [])]
    p join(NULL, 1, join(join(NULL, 2, NULL), 3, NULL)) #=> ([[] 1 []] 2 [[] 3 []])
    p join(NULL, 1, join(NULL, 2, join(NULL, 3, NULL))) #=> [([] 1 []) 2 ([] 3 [])]
  end
end

Redblacktree.new.example

なお、 Wikipedia の Join-based tree algorithms にも元論文由来のコンセプト・コードが記載されているのですけど、 おもしろいことに、 元論文にも Wikipedia にも、 両方それぞれで異なる、 微妙なミスが紛れ込んでいます。 以下のコードは元論文の本文の自然言語で記述してあるふるまいに合うように、 ミスを修正してあります。

#@<赤黒木クラス@>=
class Redblacktree
#@<Node モジュールを定義します@>
#@<Red クラスを定義します@>
#@<Black クラスを定義します@>
#@<NULL インスタンスを定義します@>
#@<join 関数を定義します@>
private
#@<join_right プライベート関数を定義します@>
#@<join_left プライベート関数を定義します@>
end

葉の役割を担う NULL インスタンスの色は黒です。 この赤黒木では、 全ノードに葉までの経路内に含まれる黒ノードの個数を「黒高さ (height_black)」として記録し、 木の連結時に利用します。 また、 height_black から算出するノードの rank も連結時に使います。 葉の色は黒です。 葉の黒高さは 1 です。 葉のランクは 0 です。

#@<NULL インスタンスを定義します@>=
  NULL = Object.new
  class << NULL
    def null?() true end
    def black?() true end
    def red?() false end
    def height_black() 1 end
    def rank() 0 end
    def inspect() '[]' end
  end

Node オブジェクトは左右の部分木の根と、 その間の鍵を与えて作成します。 JOIN 関数は、 葉からボトムアップで木を作成していくため、 ノードの高さをオブジェクトの作成時に求めることができます。 JOIN 関数は非破壊でノードを扱うため、 属性への書き込みメソッドを持たせてません。

#@<Node モジュールを定義します@>=
  module Node
    attr_reader :left, :key, :right
    attr_reader :height_black

    def initialize(p0, k, p1)
      @left, @key, @right = p0, k, p1
      @height_black = [p0.height_black, p1.height_black].max
    end

    def null?() false end
  end

赤色ノード・オブジェクトのランクは奇数です。

#@<Red クラスを定義します@>=
  class Red
    include Node
    def black?() false end
    def red?() true end
    def rank() 2 * @height_black - 1 end
    def inspect() '(%p %p %p)' % [@left, @key, @right] end
  end

黒色ノード・オブジェクトのランクは偶数です。 黒高さには黒色ノード自身も個数に数え入れる約束です。 ランクは偶数です。

#@<Black クラスを定義します@>=
  class Black
    include Node

    def initialize(p0, k, p1)
      super
      @height_black += 1
    end

    def black?() true end
    def red?() false end
    def rank() 2 * (@height_black - 1) end
    def inspect() '[%p %p %p]' % [@left, @key, @right] end
  end

黒高さとランクの関係を例をとって調べてみましょう。 赤色と黒色の両方のノードに対して、 ランクを 2 で整数割り算した値は、 黒高さから 1 を引いた値に一致します。 つまり、 ランクを 2 で整数除算した結果は、 黒高さの代わりになるということです。 さらに 2 を掛けると、 黒色ノードの場合に限ってランクの元の値に戻ります。 赤色ノードは奇数なので、 元のランクの値に戻ることは決してありません。 この黒色ノードと赤色ノードのランクの演算に生じる違いを、 連結の条件判定時に利用します。

  # T.rank = 2 * (T.height_black − 1) if T is black
  # T.rank = 2 * T.height_black − 1   if T is red
  #
  # root B  h==4, r==6, r/2==3, r/2*2==6
  #      |
  #      R  h==3, r==5, r/2==2, r/2*2==4
  #      |
  #      B  h==3, r==4, r/2==2, r/2*2==4
  #      |
  #      B  h==2, r==2, r/2==1, r/2*2==2
  #      |
  #      R  h==1, r==1, r/2==0, r/2*2==0
  #      |
  # leaf B  h==1, r==0, r/2==0, r/2*2==0

join 関数は、 2 つの赤黒木の間にキーをはさんで連結した新しい赤黒木を返します。 join 関数はキーの値の大小関係には無頓着です。 単にはさんでくっつけるだけです。 なお、 join 関数は下請けなので、 便宜的に木の根に相当するノードまたは葉を引数に与えています。 この関数が返す木も、 それの根に相当する赤色ノードもしくは黒色ノードで表すものとしています。

ところで、 伝統的な赤黒木では根を必ず黒色ノードに色塗りする約束がありましたが、 この赤黒木では赤色ノードのままで根になることを許しています。 もちろん、 join 関数は根が赤色ノードの木も連結できるようになっています。 join 関数は、 左右の赤黒木の高い方へ低い方をつなげる振り分けをします。 そして、 連結した木の根を赤色ノードにするか、 黒色ノードにするかを調整します。

#@<join 関数を定義します@>=
  def join(tree_left, key, tree_right)
    if tree_left.height_black > tree_right.height_black
      tree_prime = join_right(tree_left, key, tree_right)
      if tree_prime.red? and tree_prime.right.red?
        Black.new(tree_prime.left, tree_prime.key, tree_prime.right)
      else
        tree_prime
      end
    elsif tree_left.height_black < tree_right.height_black
      tree_prime = join_left(tree_left, key, tree_right)
      if tree_prime.red? and tree_prime.left.red?
        Black.new(tree_prime.left, tree_prime.key, tree_prime.right)
      else
        tree_prime
      end
    elsif tree_left.black? and tree_right.black?
      Red.new(tree_left, key, tree_right)
    else
      Black.new(tree_left, key, tree_right)
    end
  end

左側の赤黒木の方が右側よりも高い場合に、 連結をおこなうのが join_right 関数です。 再帰呼び出しで書いてあります。

まず、 左側の木の右端の経路を降りていきます。 右側の木の根の黒色高さと同じになる黒色高さを持つ左側の黒色ノードまで降りたら、 そこで降るのを止めます。 この条件を判定しているのが、 最初の if の条件式です。 そこまで降りた段階で、 両側のノードでキーをはさんだ赤色ノードを作ってから、 今度は再帰呼出しを逆戻りしていきます。 この新しく作った赤色ノードの左は必ず黒色ノードで、 右は赤色か黒色の両方の場合がありえます。

逆戻り中の処理は外側の if 式の else 区の tree_prime_right 変数へ束縛している let 式の本体部です。 本体部は、 バランス崩れを調整するための条件分けになっています。 通常の赤黒木の挿入手続きのバランス調整からの違いとして、 黒色ノード内での再配置がありません。 常に、 黒色ノードの分割でバランス調整をおこないます。

#@<join_right プライベート関数を定義します@>=
  def join_right(tree_left, key, tree_right)
    if tree_left.rank == tree_right.rank/2*2
      # ↑は tree_left.black? and tree_left.height_black == tree_right.height_black
      Red.new(tree_left, key, tree_right)
    else
      tree_prime_right = join_right(tree_left.right, key, tree_right)
      if tree_left.black? and tree_prime_right.red? and tree_prime_right.right.red?
        tree_prime_rr = tree_prime_right.right
        Red.new(Black.new(tree_left.left, tree_left.key, tree_prime_right.left),
                tree_prime_right.key,
                Black.new(tree_prime_rr.left, tree_prime_rr.key, tree_prime_rr.right))
      elsif tree_left.red?
        Red.new(tree_left.left, tree_left.key, tree_prime_right)
      else
        Black.new(tree_left.left, tree_left.key, tree_prime_right)
      end
    end
  end

逆に右側の方が左側よりも高い場合の連結処理は、 join_left 関数がおこないます。 join_right 関数の左右を入れ換えれば良いわけです。

#@<join_left プライベート関数を定義します@>=
  def join_left(tree_left, key, tree_right)
    if tree_left.rank/2*2 == tree_right.rank
      Red.new(tree_left, key, tree_right)
    else
      tree_prime_left = join_left(tree_left, key, tree_right.left)
      if tree_right.black? and tree_prime_left.red? and tree_prime_left.left.red?
        tree_prime_ll = tree_prime_left.left
        Red.new(Black.new(tree_prime_ll.left, tree_prime_ll.key, tree_prime_ll.right),
                tree_prime_left.key,
                Black.new(tree_prime_left.right, tree_right.key, tree_right.right))
      elsif tree_right.red?
        Red.new(tree_prime_left, tree_right.key, tree_right.right)
      else
        Black.new(tree_prime_left, tree_right.key, tree_right.right)
      end
    end
  end

バランス調整のふるまいを辿ってみましょう。 例えば、 pN を全部が同じ黒高さの黒色ノードとして、 join_right の動きを追ってみます。 左側の木の連結部を含む黒色ノードの右が黒色ノードで、 右側の木の根が黒色の単純な場合は、 黒色ノードの右を新しい赤色ノードで置き換えるだけです。

join_right [p1 k1 p2], k2, p3
=> [p1 k1 (p2 k2 p3)]

join_right [(p1 k1 p2) k2 p3], k3, p4
=> [(p1 k1 p2) k2 (p3 k3 p4)]

右側の木の根が黒色のとき、 連結部を含む黒色ノードの右が赤色ノードのときは、 最右の黒色ノードを赤色ノードに置き換えるとバランスが崩れます。 そのため、 分割でバランスを調整します。

join_right [p1 k1 (p2 k2 p3)], k3, p4
=> [p1 k1 (p2 k2 (p3 k3 p4))]
=> ([p1 k1 p2] k2 [p3 k3 p4])

join_right [(p1 k1 p2) k2 (p3 k3 p4)], k4, p5
=> [(p1 k1 p2) k2 (p3 k3 (p4 k4 p5))]
=> ([(p1 k1 p2) k2 p3] k3 [p4 k4 p5])

右側の木の根が赤色のときは、 左側の木の最右の黒色ノードを赤色ノードに置換すると、 必ずバランスが崩れてしまいます。 中でも、 左側の木の右が赤色ノードのときは、 連結直後は右側は 3 重の赤色ノードになってしまいます。 この場合でも、 分割することでバランスを調整できます。

join_right [p1 k1 p2], k2, (p3 k3 p4)
=> [p1 k1 (p2 k2 (p3 k3 p4))]
=> ([p1 k1 p2] k2 [p3 k3 p4])

join_right [(p1 k1 p2) k2 p3], k3, (p4 k4 p5)
=> [(p1 k1 p2) k2 (p3 k3 (p4 k4 p5))]
=> ([(p1 k1 p2) k2 p3] k3 [p4 k4 p5])

join_right [p1 k1 (p2 k2 p3)], k3, (p4 k4 p5)
=> [p1 k1 (p2 k2 (p3 k3 (p4 k4 p5)))]
=> ([p1 k1 p2] k2 [p3 k3 (p4 k4 p5)])

join_right [(p1 k1 p2) k2 (p3 k3 p4)], k4, (p5 k5 p6)
=> [(p1 k1 p2) k2 (p3 k3 (p4 k4 (p5 k5 p6)))]
=> ([(p1 k1 p2) k2 p3] k3 [p4 k4 (p5 k5 p6)])

配列のスライスで cdr

Array オブジェクトを正規リストとみなしてみましょう。 空の Array オブジェクトは、 当然、 空リストです。 では、 3 個の要素を持つ Array オブジェクトではどうでしょうか。 car は先頭の要素なのは明らかです。 一方、 cdr は先頭を除く残りの要素が並んだリストになっているべきです。

null?([]) #=> true

car([:a, :b, :c]) #=> :a
cdr([:a, :b, :c]) #=> [:b, :c]
cddr([:a, :b, :c]) #=> [:c]
cdddr([:a, :b, :c]) #=> []

素朴には、 cdr は、 Array オブジェクトをスライスして新しく作成した Array オブジェクトを返すことになるのでしょう。

def car(x) x.first end
def cdr(x) x[1..-1] end

Ruby 処理系の内部実装が、 Array オブジェクトのスライスと元のオブジェクトとが、 実態となる要素列を共用してくれていると良いのですけど、 要素列も複写する実装になっているかもしれません。 それに、 スライスと元とでは要素列を常に共用しておかないと、 set-car! 手続きのふるまいが Pair オブジェクトの並びでリストを作る場合とで異なってしまいかねません。

そこで、 cdr のために、 あからさまにスライス・オブジェクトでラッピングすることにしましょう。

def null?(x)
  x.nil? or (Array === x and x.empty?)
end

def pair?(x)
  if Array === x
    x.size > 0
  else
    x.respond_to?(:first) and x.respond_to?(:last)
  end
end

def car(x)
  pair?(x) or raise "not a pair -- car"
  x.first
end

def cdr(x)
  pair?(x) or raise "not a pair -- cdr"
  if Array === x
    TailSlice.new(x, 1)
  else
    x.last
  end
end
  
class TailSlice
  def initialize(a, i) @ary, @cursor = a, i end
  def first() @ary[@cursor] end
  def last()
    (@cursor + 1 < @ary.size) ? self.class.new(@ary, @cursor + 1) : nil
  end
  def inspect() @ary[@cursor .. -1].inspect end
end

proper-list? 手続きのアセンブリ記述

SICP では仮想マシンの解釈器をわざわざ使ってインタプリタコンパイラを記述してますけど、 Scheme でそのまま実行できる仮想ストアド・レジスタ機械のアセンブリを、 Scheme の手続きとして記述することができます。 例として、 正規リストかどうかを検査する手続きを記述してみました。

(define (proper-list? x)
 (define (go k) (k))
 (define (return v) v)
 (let ((t0 #f) (t1 #f) (t2 #f))
  (define (L1) (set! t1 x)
               (set! t2 t1)
               (go   L2) )
  (define (L2) (set! t0 (null? t2))
               (if t0 (go L5) (begin
               (set! t0 (pair? t2))
               (if t0 (go L3) (begin
               (set! t1 'dotted)
               (go   L6) )))))
  (define (L3) (set! t2 (cdr t2))
               (set! t0 (null? t2))
               (if t0 (go L5) (begin
               (set! t0 (pair? t2))
               (if t0 (go L4) (begin
               (set! t1 'dotted)
               (go   L6) )))))
  (define (L4) (set! t1 (cdr t1))
               (set! t2 (cdr t2))
               (set! t0 (eq? t1 t2))
               (set! t0 (not t0))
               (if t0 (go L2) (begin
               (set! t1 'cyclic)
               (go   L6) )))
  (define (L5) (set! t1 'proper)
               (go   L6) )
  (define (L6) (set! t2 'proper)
               (set! t0 (eq? t1 t2))
               (return t0) )
  (L1)))