二択問題

雑誌でよく見かける適性テストなどは、答えの選択次第で次の問題が変わって行くようなチャート形式になっています。これを構造化プログラムで記述しようとすると、次のようにどうしようもなくネストが深くなる if ブロックになってしまいます。

if ( $ans = 'a' ) {
   if ( $ans2 = 'x' ) {
   ............
} elsif ( $ans == 'b' ) {
   ...........
}

そこで各問題をひとつのノード(節)・オブジェクトと考えて、そのノードから、答えの選択によって別のノードへジャンプする様なプログラムを考えてみました。例えばノード１の答えが yes の場合、ノード２へジャンプする。また、答えが no の場合ノード３へジャンプする。というふうに、各ノードの答えとジャンプ先のノードを結びつける操作をするだけで、問題のチャートを自動的にたどれるようにしました。

先ず属性に問題、答えの選択枝、ジャンプ先のノード名をもつクラス Node.pm を次のように設計します。

package Node;

sub new {
    my($class) = shift;
    my($self) = {};
    bless( $self, $class );
    $self->{QUESTION} = 'default';
    $self->{MESSAGE} = 'Please answer yes or no :';
    $self->{LAST} = 'no';
    my(%hash) = @_;
    foreach $key ( keys( %hash ) ) {
        $self->{$key} = $hash{$key};
    }
    return $self;
}

sub ask {
    my($self) = shift;
    print $self->{QUESTION}, "\n";
    if ( $self->{LAST} eq 'no' ) {
        LABEL:
        print $self->{MESSAGE};
        $answer = <>;
        chomp($answer);
        if ( ! defined( $self->{$answer} ) ) { goto LABEL };
        return $self->{$answer};
    } else { return 'end' }
}
1;
# Node.pm

簡単に属性の説明をします。QUESTION はそのノードの問題です。MESSAGE は答えの入力用のプロンプトです。LAST が yes なら、そのノードが答えの選択肢を持たずそこでノードが終ることを示します。答えは ハッシュのキー名で、ハッシュの値はその答えを選択したときにジャンプするオブジェクト名です。

次にこれらのオブジェクトの関係を管理する Linker.pm クラスを作成します。

package Linker;

sub start {
    my($object) = shift;
    local(*link) = shift;
    do {
        $object_name = $object->ask;
        $object = $link{ $object_name };
    } until ( ! defined( $object ) );
}
1;
# Linker.pm

このクラスは start メソッドだけを持っています。start メソッドは第１引数に最初のノードのオブジェクトへのリファレンス、第２引数に、オブジェクト名とオブジェクトのリファレンス名をマッチさせたテーブルをとります。start メソッドは最初のノードからはじめて、答えの選択によって次のノードをたどりノードの属性 LAST が yes になったところで終了します。

メインプログラム test_node.pl は次のようになります。

#!/usr/bin/perl
use Node;
use Linker;

$node_1 = new Node( 'QUESTION' => 'Which do you like better, Hikaru or Ryoko?',
                    'MESSAGE' => 'Please answer Hikaru or Ryoko: ',
                    'Hikaru' => 'hikaru', 'Ryoko' => 'ryoko' );
$hikaru = new Node( 'QUESTION' => 'Hi, I am Hikaru.', 'LAST' => 'yes' );
$ryoko = new Node( 'QUESTION' => 'Hi, I am Ryoko.', 'LAST' => 'yes' );

%link = ( 'hikaru' => $hikaru,
          'ryoko' => $ryoko );

Linker::start( $node_1, *link );

まず各ノードを設計します。$node_1 の場合は質問が 'Which do you like better, Hikaru or Ryoko?' です。入力用のプロンプトは 'Please answer Hikaru or Ryoko: ' です。選択枝は 'Hikaru' と 'Ryoko' でそれぞれオブジェクト hikaru と ryoko へジャンプします。選択肢の数は自由に設定できます。$hikaru ノードは質問(と言うかメッセージ)が 'Hi, I am Hikaru' で、これが最期のノードなので、LAST が 'yes' となります。%link はオブジェクト名と、オブジェクトのリファレンスを結びつけるためのテーブルです。

実行結果は次のようになります。

$ perl -w test_node.pl 
Which do you like better, Hikaru or Ryoko?
Please answer Hikaru or Ryoko: Hikaru
Hi, I am Hikaru.

if文のネストに煩わされることなくノードの性質を記述するだけで簡単にプログラムが動いてしまうのには驚かされます。また、メインプログラムを見ると、ほとんど考えがそのままプログラムになっている感じで「考えるようにプログラムする」とでも言えそうな感じです。これは、おそらく Perl のオブジェクトが構造体の属性を持たず、何でもハッシュに投げ込めるからではないでしょうか。Perl の連想配列とオブジェクトを活用すると、アイディアがストレートにプログラム化することも不可能ではないような気がします(少々大袈裟？)。畏るべし物体的真珠的プログラム。

自動診断プログラム

おまけで肺炎の治療法をきめるプログラム pneumonia.pl を下に示します。

#!/usr/bin/perl
use Node;
use Linker;

$haien = new Node( 'QUESTION' => '重症度',
                   'MESSAGE' => '1 軽症〜中等症  2 重症  3 特殊病態下 : ',
		  '1' => 'keisyo', '2' => 'jusyo', '3' => 'E');
$keisyo = new Node( 'QUESTION' => '細菌性肺炎ですか、非定型肺炎ですか。',
		   'MESSAGE' => '1 細菌性  2 非定型 : ',
		   '1' => 'saikin', '2' => 'hiteikei' );
$jusyo = new Node( 'QUESTION' => "L.pneumonia, M.pneumoniae, S.pneumoniae, C.psittaci, P.carinii\n等の感染が考えられます。",
                   'MESSAGE' => '1 次へ  :',
		  '1' => 'D');
$saikin = new Node( 'QUESTION' => '迅速診断はしましたか。',
		   'MESSAGE' => '1 未施行  2 施行 : ',
		   '1' => 'A', '2' => 'siko' );
$hiteikei = new Node( 'QUESTION' => 'M. pneumonie, C. phneumonie, C. bumetiiが疑われます。',
                   'MESSAGE' => '1 次へ',
		     '1' => 'C');
$siko = new Node( 'QUESTION' => '原因菌は推定できましたか。',
                  'MESSAGE' => '1 不明  2 推定 : ',
                  '1' => 'A', '2' => 'B');
$A = new Node( 'QUESTION' => 'A 群の抗生物質を使ってください。',
               'LAST' => 'yes');
$B = new Node( 'QUESTION' => 'B 群の抗生物質を使ってください。',
               'LAST' => 'yes');
$C = new Node( 'QUESTION' => 'C 群の抗生物質を使ってください。',
               'LAST' => 'yes');
$D = new Node( 'QUESTION' => 'D 群の抗生物質を使ってください。',
               'LAST' => 'yes');
$E = new Node( 'QUESTION' => 'E 群の抗生物質を使ってください。',
               'LAST' => 'yes');

%list = ('haien' => $haien,
         'keisyo' => $keisyo,
         'jusyo' => $jusyo,
         'saikin' => $saikin,
         'hiteikei' => $hiteikei,
         'siko' => $siko,
         'A' => $A,
         'B' => $B,
         'C' => $C,
         'D' => $D,
         'E' => $E );

Linker::start( $haien, *list );

実行結果は次のようになります。

$ perl -w pneumonia.pl
重症度
1 軽症〜中等症  2 重症  3 特殊病態下 : 1
細菌性肺炎ですか、非定型肺炎ですか。
1 細菌性  2 非定型 : 1
迅速診断はしましたか。
1 未施行  2 施行 : 2
原因菌は推定できましたか。
1 不明  2 推定 : 2
B 群の抗生物質を使ってください。