サンプル - toy-lang

サンプル

円周率計算

   defun pi () {
       set (k a b a1 b1) (2 4 1 12 4);
   
       loop {
           set (p q k)
               ([$k * $k] [[2 * $k] + 1] [$k + 1]);
           set (a b a1 b1)
               ($a1 $b1 [[$p * $a] + [$q * $a1]] [[$p * $b] + [$q * $b1]]);
   
           set (d d1) ([$a / $b] [$a1 / $b1]);
   
           while {$d = $d1} do: {
               print file: $stdout $d;
               $stdout flush;
   
               set (a a1) ([10 * [$a % $b]] [10 * [$a1 % $b1]]);
               set (d d1) ([$a / $b] [$a1 / $b1]);
           };
       };
   };

実行例:

   $ toysh
   *** Start toy-lang interpreter version 0.3.0.
   > pi
   31415926535897932384626433832795028841971693993751058209....

上記プログラムは1995年頃、rubyが公開されて間もない頃 rubyで書いたもの(現在rubyのsampleとしてソースと同時に配布されている)ですが、それを今回 toy-lang に書き換えたものです。

Yコンビネータ（本体）

   defun Y(f) {
       [fun (g) {
           fun (m) {
               [$f [$g $g]] $m;
           }
       }] [fun (g) {
           fun (m) {
               [$f [$g $g]] $m;
           }
       }];
   };

Yコンビネータ適用例 - fact(10)

   [Y [
       fun (f) {
           fun (x) {
               if {$x <= 1} then: {return 1};
               $x * [$f [$x - 1]];
           }
       }
   ]] 10
   
   => 3628800

goto による末尾再帰

   defun fact-recur (n) {
       fact-recur-sub $n 1;
   };
   
   defun fact-recur-sub (n a) {
       if {$n < 1} then: {return $a};
       goto fact-recur-sub [$n - 1] [$n * $a];
   };

flat コマンド - オブジェクトで使えるメソッドの一覧を出す。

   defun flat (o) {
       set h `Hash;
       flat-sub $o $h;
   
       set l ();
       $h each do: {| m c |
           $l append! ["" . $c "::" $m];
       };
       [lsort $l] each do: {| p | println $p};
   };
   
   defun flat-sub (o h) {
       [$o vars] each do: {| m |
   
           case [type? [$o var? $m]]
           NATIVE {
               if {$h set? $m} else: {$h set $m $o};
           }
           FUNC {
               if {$h set? $m} else: {$h set $m $o};
           };
       };
   
       [$o delegate?] each do: {| c |
           flat-sub $c $h;
       };
   };

grep コマンド

UNIX の grep に似たコマンド。

   defun grep (pat file) {
       set f `File(mode: i $file);
       try {
           set n 1;
           $f each do: {| r |
               if {$r =~ $pat} then: {
                   print $file ":" $n ": " $r;
               };
               $n ++;
           };
       }
       fin: {
           $f close;
       };
       println;
   
       true;
   };

たらい回し関数(遅延評価バージョン)

たらい回し関数を遅延評価バージョンで作ってみました。ソースは以下のような感じ。

    # tarai function lazy version

    defun tarai-lazy (&x &y &z) {
       if [$x <= $y]
       then: $y
       else: {
           tarai-lazy 
                {tarai-lazy [$x - 1] $y $z}
                {tarai-lazy [$y - 1] $z $x}
                {tarai-lazy [$z - 1] $x $y}
       };
    };

通常バージョンとの実行時間の差は以下のとおり。

* time {tarai 12 6 0}
Elapsed time: 74.655180
result[INTEGER]=> 12
* time {tarai-lazy 12 6 0}
Elapsed time: 0.008021
result[INTEGER]=> 12

一瞬で終わります。
遅延評価関数定義の引数に '&’ を付けて、遅延評価関数を呼ぶときに eval ではなく ([...] ではなく) クロージャを({...} を) 渡すことにより、遅延評価関数内でその引数の参照時に一度だけ計算します。
呼び出し側も遅延評価の呼び出しであることを意識することが必要ですが。

クイックソート

   defun lsort (l order: cmp) {
       if {[$l len] <= 1} then: {return $l};
       if [set? cmp] else: {set cmp >};
       set pivot [$l car];
       set l [$l cdr];
   
       return [[lsort [$l filter {| i | $pivot $cmp $i}] order: $cmp]
           concat $pivot
            [lsort [$l filter {| i | ! [$pivot $cmp $i]}] order: $cmp]];
   };

素数を求める

   # calc prime
   
   defun prime (n) {
     set prime (3 5);
     set last [$prime last];
     set cand [$last item];
     set c 0;
   
     while {true} do: {
       if {$c > $n} then: {return $prime};
   
       $cand ++ 2;
       $prime each do: {| i |
         if {[$i * 2] > $cand} then: {break};
         if {[$cand % $i] = 0} then: {$cand ++ 2; retry};
       };
       #found prime
       set last [$last + $cand];
       set cand [$last item];
       $c ++;
     };
   };
   
   time {prime 1000;};

たらい回し関数

   # tarai function
   
   defun tarai (x y z) {
       if {$x <= $y}
           then: {return $y}
           else: {
               tarai [tarai [$x - 1] $y $z]
                     [tarai [$y - 1] $z $x]
                     [tarai [$z - 1] $x $y];
       };
   };
   
   time {tarai 12 6 0};

クラスの継承ツリーを表示

   defun class-tree (class indent: ind) {
       if {set? ind} else: {set ind 0};
   
       # print indent
       if {$ind > 0} then: {1 each to: $ind do: {| i | print "  "}};
   
       println $class;
       if {"Object" = $class} then: {return;};
   
       [$class delegate?] each do: {| i |
           class-tree $i indent: [$ind + 1];
       };
   };

コンストラクタを delegate の継承関係を遡って実行する。

コンストラクタは、オブジェクト生成時に指定したクラスの init メソッドしか呼ばれないので、init メソッドの中に apply-constructor の呼び出しを書くことで、存在するすべての init メソッドを呼べます。

   defun apply-constructor () {
       [[self] delegate?] each do: {| i |
           apply-constructor-sub $i;
       };
   };
   
   defun apply-constructor-sub (o) {
       set l [$o delegate?];
       if {$l null?} then: {return};
   
       $l each do: {| i |
            apply-constructor-sub $i;
            try {
                [$i var? init];
            }
            catch: {};
       };
   };

---