Think Stitch
PRINCIPIA  最近の更新


代数的データ型のインスタンス生成

この文書は LISP Library 365 への参加エントリです。

関数型プログラミング言語には代数的データ型(あるいはフリータイプ)というものを持っているものがあって,それを使って問題領域のデータを表現(モデル化)できるようになっていますよね。例えばこんな感じです:

datatype 'a tree = Leaf | Node 'a "'a tree" "'a tree"

記法は言語によっていろいろあるようですが,ここでは Isabelle 風に書きました。これは木を表したものです。葉(Leaf)は何も属性を持っていなくて,代わりに節(Node)が型パラメータ 'a の値を1つ持てるようにした場合です。

Lisp だともっと簡易に,というか"よいかげん"にというか,タグ付きのリストで表すことが多いと思います。例えば例を書くとこんな感じです:

Leaf
(Node 7 Leaf Leaf)
(Node 7 (Node 4 Leaf Leaf) (Node 13 Leaf Leaf))

こういったデータ表現を処理する関数を書いたとき,テストのために型に属する値をある程度網羅的に列挙したくなります。そこで代数的データ型の定義を与えるとインスタンスのストリームを返してくれるライブラリを書いてみました。

処理系は Gauche です。他の処理系への移植もかんたんだと思います。ソースコードはこのページの一番最後にあります。

使い方

使うのはマクロ algebraic-datatypes-instance-streams だけです。これに型定義のリストを渡します。すると各型に対応するインスタンスのストリームが多値で返ってきます。

(algebraic-datatypes-instance-streams 型定義 ...)

型定義は次のような形で指定します。型名はシンボルで指定します。

型定義 ::= (型名 項定義1 項定義2 ...)

項は属性を持たないリテラルか,あるいはコンストラクタ+属性からなる複合項のどちらかです。リテラルはアトムで,複合項はリストで表します。リストの先頭はコンストラクタを表すシンボルです。残りの要素は属性の型名です。

項定義 ::= アトム | (コンストラクタ 型名1 型名2 ...)

使用例

先に,得られたストリームの中身を確認するための手続きを用意しておきます。

(define (sprn s c)
  (for-each print (stream->list (stream-take-safe s c))))

List

最初は線型リストの例です。algebraic-datatypes-instance-streams は指定した型の数だけストリームを返すので,define-values を使って変数に格納することにします。

(define-values
  (A L)
  (algebraic-datatypes-instance-streams
   (Atom a b)
   (List Nil (Cons Atom List))))

Atom はリテラル2個だけからなります。

(sprn A 10)
=>
a
b

List の方は以下のようになります。

(sprn L 10)
=>
Nil
(Cons a Nil)
(Cons b Nil)
(Cons a (Cons a Nil))
(Cons b (Cons a Nil))
(Cons a (Cons b Nil))
(Cons b (Cons b Nil))
(Cons a (Cons a (Cons a Nil)))
(Cons b (Cons a (Cons a Nil)))
(Cons a (Cons b (Cons a Nil)))

Even and Odd

偶数と奇数の定義例です。S は後者関数(Successor)のつもりです。

(define-values
  (E O)
  (algebraic-datatypes-instance-streams
   (Even 0 (S Odd))
   (Odd (S Even))))
(sprn E 5)
=>
0
(S (S 0))
(S (S (S (S 0))))
(S (S (S (S (S (S 0))))))
(S (S (S (S (S (S (S (S 0))))))))
(sprn O 5)
=>
(S 0)
(S (S (S 0)))
(S (S (S (S (S 0)))))
(S (S (S (S (S (S (S 0)))))))
(S (S (S (S (S (S (S (S (S 0)))))))))

Tree

木の例です。最初に挙げた例と違って葉の方に属性を持たせるようにしてみました。

(define-values
  (A T)
  (algebraic-datatypes-instance-streams
   (Atom a b)
   (Tree (Leaf Atom) (Node Tree Tree))))
(sprn A 10)
=>
a
b

残念ながら作りの都合により,ノードの少ない方から順番に生成されるわけではありません。しかしどのインスタンスもいつかは必ず現れます。ただし大量にメモリを消費する場合があります。

(sprn T 20)
=>
(Leaf a)
(Node (Leaf a) (Leaf a))
(Leaf b)
(Node (Node (Leaf a) (Leaf a)) (Leaf a))
(Node (Leaf a) (Node (Leaf a) (Leaf a)))
(Node (Leaf b) (Leaf a))
(Node (Leaf a) (Leaf b))
(Node (Node (Leaf a) (Leaf a)) (Node (Leaf a) (Leaf a)))
(Node (Leaf a) (Node (Node (Leaf a) (Leaf a)) (Leaf a)))
(Node (Node (Node (Leaf a) (Leaf a)) (Leaf a)) (Leaf a))
(Node (Leaf a) (Node (Leaf a) (Node (Leaf a) (Leaf a))))
(Node (Node (Leaf a) (Leaf a)) (Leaf b))
(Node (Leaf a) (Node (Leaf b) (Leaf a)))
(Node (Leaf b) (Node (Leaf a) (Leaf a)))
(Node (Leaf a) (Node (Leaf a) (Leaf b)))
(Node (Node (Leaf a) (Leaf a)) (Node (Node (Leaf a) (Leaf a)) (Leaf a)))
(Node (Leaf a) (Node (Node (Leaf a) (Leaf a)) (Node (Leaf a) (Leaf a))))
(Node (Node (Leaf a) (Node (Leaf a) (Leaf a))) (Leaf a))
(Node (Leaf a) (Node (Leaf a) (Node (Node (Leaf a) (Leaf a)) (Leaf a))))
(Node (Node (Leaf a) (Leaf a)) (Node (Leaf a) (Node (Leaf a) (Leaf a))))

内部解説

はじめにやや汎用的なストリームを処理する関数を5つ用意します。より詳しく知りたい方は SICP の 3.5 節を見てください。

stream-interleave

(stream-interleave s1 s2) は2つのストリームの要素を交互に並べたストリームを作ります。マージするということです。

(define (stream-interleave s1 s2)
  (stream-delay
   (if (stream-null? s1)
       s2
       (stream-cons
        (stream-car s1)
        (stream-interleave s2 (stream-cdr s1))))))

stream-pairs

(stream-pairs s1 s2) は2つのストリームの要素のすべての組み合わせペアからなるストリームを作ります。

(define (stream-pairs s1 s2)
  (stream-delay
   (if (stream-null? s1)
       stream-null
       (stream-interleave
        (stream-map (lambda (x) (cons (stream-car s1) x)) s2)
        (stream-pairs (stream-cdr s1) s2)))))

SICP の Exercise 3.68 で指摘されていますが,stream-delay がないとこの手続きは無限ループに陥ります。遅延評価を生に使ってぎりぎりまで削る(?)こともできますけど,ここは Gauche マニュアルのアドバイスに従って stream-delay を入れることにしました。

この関数は一言でいえば直積を求めているわけですけど,すべての組み合わせを求めるためには生成したストリームの要素をすべて残しておかなければならないので,その分だけメモリを消費することになります。

stream-tag

(stream-tag tag s) はストリーム s の各要素にタグ tag を cons した値を要素とするストリームを作ります。

(define (stream-tag tag s)
  (stream-delay
   (stream-map (lambda (x) (cons tag x)) s)))

stream-cartesian-product

stream-cartesian-product はストリームのリストを受け取ります。各ストリームから任意の要素を1個ずつ取り出して作った組(リスト)からなるストリームを作ります。stream-pairs の拡張版といった感じでしょうか。

(define (stream-cartesian-product ss)
  (stream-delay
   (if (null? (cdr ss))
       (stream-map list (car ss))
       (stream-pairs (car ss)
                     (stream-cartesian-product (cdr ss))))))

stream-interleaves

stream-interleaves も stream-interleave の拡張版という感じで,任意個数のストリームをマージします。

(define (stream-interleaves ss)
  (stream-delay
   (cond ((null? ss) stream-null)
         ((stream-null? (car ss))
          (stream-interleaves (cdr ss)))
         (else
          (stream-interleave
           (car ss)
           (stream-interleaves (cdr ss)))))))

algebraic-datatypes-instance-streams

型に対応するストリームは相互に参照されるので,letrec を使って定義するようにします。それから定義されたストリームを多値で返します。

(define-macro (algebraic-datatypes-instance-streams . def-list)
  `(letrec ,(expand-algebraic-datatypes-defs def-list)
     (values ,@(map car def-list))))

ストリームの生成はとても簡単です。まず型定義をリテラルと複合項に分けます。リテラルの部分は基底としてストリームの先頭に置きます。そのために stream-cons* を使いました。複合項の部分は,引数となる型の直積を stream-cartesian-product で作って,stream-tag によって先頭にコンストラクタシンボルを付加します。複合項定義は複数あり得るので,これらを stream-interleaves でマージします。

(define (expand-algebraic-datatypes-defs def-list)
  (map (lambda (def)
         (let ((name (car def))
               (term-def-list (cdr def)))
           (let ((base-terms (filter (complement pair?) term-def-list))
                 (ctor-terms (filter pair? term-def-list)))
             `(,name
               (stream-delay
                (stream-cons*
                 ,@(map (lambda (x) `',x) base-terms)
                 (stream-interleaves
                  (list
                   ,@(map (lambda (ctor-term)
                            `(stream-tag ',(car ctor-term)
                                         (stream-cartesian-product
                                          (list
                                           ,@(cdr ctor-term)))))
                          ctor-terms)))))))))
       def-list))

ソースコード

(define-module algebraic-datatypes-instance-streams
  (extend util.stream)
  (export algebraic-datatypes-instance-streams
          stream-interleaves
          stream-cartesian-product
          stream-tag))

(select-module algebraic-datatypes-instance-streams)
  
(define (stream-interleave s1 s2)
  (stream-delay
   (if (stream-null? s1)
       s2
       (stream-cons
        (stream-car s1)
        (stream-interleave s2 (stream-cdr s1))))))

(define (stream-pairs s1 s2)
  (stream-delay
   (if (stream-null? s1)
       stream-null
       (stream-interleave
        (stream-map (lambda (x) (cons (stream-car s1) x)) s2)
        (stream-pairs (stream-cdr s1) s2)))))

(define (stream-tag tag s)
  (stream-delay
   (stream-map (lambda (x) (cons tag x)) s)))

(define (stream-cartesian-product ss)
  (stream-delay
   (if (null? (cdr ss))
       (stream-map list (car ss))
       (stream-pairs (car ss)
                     (stream-cartesian-product (cdr ss))))))

(define (stream-interleaves ss)
  (stream-delay
   (cond ((null? ss) stream-null)
         ((stream-null? (car ss))
          (stream-interleaves (cdr ss)))
         (else
          (stream-interleave
           (car ss)
           (stream-interleaves (cdr ss)))))))

(define-macro (algebraic-datatypes-instance-streams . def-list)
  `(letrec ,(expand-algebraic-datatypes-defs def-list)
     (values ,@(map car def-list))))

(define (expand-algebraic-datatypes-defs def-list)
  (map (lambda (def)
         (let ((name (car def))
               (term-def-list (cdr def)))
           (let ((base-terms (filter (complement pair?) term-def-list))
                 (ctor-terms (filter pair? term-def-list)))
             `(,name
               (stream-delay
                (stream-cons*
                 ,@(map (lambda (x) `',x) base-terms)
                 (stream-interleaves
                  (list
                   ,@(map (lambda (ctor-term)
                            `(stream-tag ',(car ctor-term)
                                         (stream-cartesian-product
                                          (list
                                           ,@(cdr ctor-term)))))
                          ctor-terms)))))))))
       def-list))
2014/03/08
© 2013,2014,2015 PRINCIPIA Limited