MPEG-4、ツリー探索、autovivification

近ごろ動画や音声データの読み書きを Scheme でしているんですが、MPEG-4 の処理が個人的にかなり楽しかったので少し書きます。

MPEG-4 のデータはこのようなツリー構造になっており、お馴染みのツリー探索のテクニックが活躍しそうな雰囲気です。

(define structure
  '((moov . (mvhd trak udta iods))
    (trak . (mdia tkhd))
    (mdia . (minf mdhd hdlr))
    (minf . (stbl vmhd smhd dinf))
    (dinf . (dref))
    (stbl . (stsd stsc stts ctts stco co64 stss stsz))
    (udta . (meta cprt))
    (meta . (ilst id32))))

(全てを網羅したものではありません。例えば子ノード (box) を持たないトップレベル box はこの図には入っていません。)

MP4 のツリー構造にはルートノードというものは無く、トップレベルの box が複数並んでいる構成のため、box を構造体 (下記) で表し、それらをリストでまとめるという方法で扱っていきます。

(define-struct box
  (size type ext-size data))

size は 32 ビットの符号無し整数で、box のサイズがそれを超える場合は size を 1 とし、64 ビットの ext-size フィールドを使う仕様になっています。

data にはバイト列か、サブツリーとして box のリストを入れます。なお、メディア本体の場合はバイト列に変換せず、入力ポートをそのまま置くこととします。

ツリーの読み込みは前述のように、トップレベル box をリストで集めるだけです。

(fun (mp4-boxes in)
  (let loop ((t '()))
    (receive (x done) (read-box in)
      ((if done reverse loop) (cons x t)))))

動画サイトの MP4 を扱う前提なので、メディア本体のデータは最後に来ることを想定しています。この順序は必ず保たなければいけません。

個々の box は以下で読み込みます。

(fun (read-box in)
  (receive (size type ext-size) (box-head in)
    (if (eq? type 'mdat)
        (values (make-box size type ext-size in) #t)
        (values (let ((dsize (data-size size ext-size)))
                  (make-box size type ext-size
                            (if (eq? type 'meta)
                                 (meta-tag dsize in)
                                (parent? type)
                                 (box-kids dsize in)
                                (read-bytes dsize in))))
                #f))))

(fun (box-kids size in)
  (let loop ((size~ 0) (kids '()))
    (if (= size~ size)
        (reverse kids)
        (receive (kid done) (read-box in)
          ;; `done' must not be #t here
          (loop (+ (box-size~ kid) size~)
                (cons kid kids))))))

parent? で子 box を持つタイプかどうかを判別します。最初の structure の左のコラムがそうです。

(define parent?
  [memq _ (map car structure)])

parent? は読み込みの際に必要ですが、ツリーの検索や更新をする場合には逆に、子からその親を調べる関数が必要になることに気づきました。

(fun (parent type)
  (ormap (fn ((cons par kids))
           (and (memq type kids) par))
         structure))

type を子に持つ親 box のシンボルを返します。#f が返った場合はトップレベル box だと判断します。

ここからが本題で、読み込んだツリー構造を更新する関数を作ります。タイトルを付けたりカバーアートを埋め込んだりする際に使うものです。

(fun (insert-box box boxes)
  (let ((par (parent (box-type box))))
    (if par
        (if (find-tree (is-box? par) boxes)
            (map-tree (fn (x)
                        (if (is-box? par x)
                          (update-box
                           x
                           (append (filter (negate
                                            (is-box? (box-type box)))
                                           (box-data x))
                                   (list box)))))
                      boxes)
            (insert-box (new-box par
                                 (if (eq? par 'meta)
                                     (list null-space box)
                                     (list box)))
                        boxes))
        (cons box boxes))))

;; Helper functions

(fun (fold-tree f s t)
  (let loop ((t t) (s s))
    (aif (f t s)
          it
         (box? t)
          (loop (box-data t) s)
         (pair? t)
          (loop (cdr t) (loop (car t) s))
         s)))

(fun (find-tree p? t)
  (prompt
    (fold-tree (lambda (x _)
                 (if (p? x) (control k x)))
               #f
               t)))

(define weight
  (fold-tree (lambda (x s)
               (if (box? x)
                    (+ (box-head-size x)
                       (weight (box-data x))
                       s)
                   (meta-box? x)
                    (+ (meta-box-size x) s)
                   (meta-data? x)
                    (+ (meta-data-size x) s)
                   (bytes? x)
                    (+ (bytes-length x) s)))
             0))

(define ext-size? [>= _ (expt 2 32)])

(define (update-box abox data)
  (let* ((size (+ (weight data) 8))
         (ext? (ext-size? size)))
    (struct-copy box abox
                 (size (if ext? 1 size))
                 (ext-size (and ext? (+ size 8)))
                 (data data))))

(fun (new-box type data)
  ;; using update-box to auto compute the size
  (update-box (make-box 0 type #f #f) data))

box をツリー内の狙った位置に投入したいということで、まず親を探して (find-tree)、もしあればその中に追加する (map-tree, update-box)、無ければ親 box を作る、という流れです。

妙なこだわりで、"!" の付く構文を一切使いたくないというのがあるせいで、find-tree と map-tree で同じ検索を2度してしまうことになるのが残念です。

ここで思い出しました。必要無い時はコンスしない map の定義方法です。

(fun (map-tree f t)
  (aif (f t)
        it
       (pair? t)
        ;; To cons less often.  See:
        ;; http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
        (let ((a (car t)) (d (cdr t)))
          (let ((a~ (map-tree f a)) (d~ (map-tree f d)))
            (if (and (eq? a a~) (eq? d d~))
                t
                (cons a~ d~))))
       (box? t)
        (let* ((x (box-data t))
               (x~ (map-tree f x)))
          (if (eq? x x~)
              t
              (update-box t x~)))
       t))

これに基づいて変更したバージョンが以下です。

(fun (insert-box box boxes)
  (let ((par (parent (box-type box))))
    (if par
        (let ((boxes~
               (map-tree (fn (x)
                           (if (is-box? par x)
                             (update-box
                              x
                              (append (filter (negate
                                               (is-box? (box-type box)))
                                              (box-data x))
                                      (list box)))))
                         boxes)))
          (if (eq? boxes boxes~)    ;not modified == par box not found
              (insert-box (new-box par
                                   (if (eq? par 'meta)
                                       (list null-space box)
                                       (list box)))
                          boxes)
              boxes~))
        (cons box boxes))))

find-tree を無くすことができました。

試しに使ってみましょう。空の box のリストに box を挿入しようとすると、

> (pp (insert-box (new-box 'ilst #f) '()))
(#(struct:box
   36
   moov
   #f
   (#(struct:box
      28
      udta
      #f
      (#(struct:box
         20
         meta
         #f
         (#"\0\0\0\0" #(struct:box 0 ilst #f #f))))))))

となり、自動的にツリー構造が生成されていることが分かります。(サイズ計算もばっちり)

検索して挿入する場合もこの通り、

> (pp
   (insert-box (new-box 'ilst #f)
               (insert-box (new-box 'cprt #f) '())))
(#(struct:box
   44
   moov
   #f
   (#(struct:box
      36
      udta
      #f
      (#(struct:box 8 cprt #f #f)
       #(struct:box
         20
         meta
         #f
         (#"\0\0\0\0" #(struct:box 8 ilst #f #f))))))))

うまく行っています。

ニコニコ動画の MP4 には udta の下に cprt (コピーライト) の box しか無いので、メタ情報 (ilst box) を追加するにはこの自動生成の機能が欠かせません。