「サンプル」の編集履歴（バックアップ）一覧はこちら

「サンプル」(2012/07/16 (月) 18:34:35) の最新版変更点

追加された行は緑色になります。

削除された行は赤色になります。

**サンプル

***円周率計算
    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
    3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725

上記プログラムは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: {};
        };
    };
 













---- 

**サンプル

***円周率計算
    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: {};
        };
    };
 













----