M.Hiroi's Home Page

Functional Programming

お気楽 Standard ML of New Jersey 入門

[ PrevPage | SML/NJ | NextPage ]

関数型電卓プログラムの作成 (2)

今回はクロージャを使って「連結リスト (linked list)」を作ってみましょう。

●クロージャによる連結リストの実装

Lisp / Scheme の場合、コンス演算子 (::) の役割を関数 cons で、関数 hd, tl の役割を関数 car, cdr で行います。ただし、SML/NJ のリストと相違点があり、Lisp / Scheme の cons は第 2 引数にリスト以外の値を与えてもかまいません。

したがって、Lisp / Scheme の cons, car, cdr には次の関係が成り立ちます。

x == car(cons(x, y)) => 1 (true)
y == cdr(cons(x, y)) => 1 (true)

演算子 == は今回作成した電卓プログラムの等値演算子と考えてください。Scheme で表すと次のようになります。

(eq? x (car (cons x y))) => #t
(eq? y (cdr (cons x y))) => #t

Scheme の場合、#t は true を、#f は false を表します。実際に Gauche (Scheme) での実行例を示します。

gosh> (define a 10)
a
gosh> (define b 20)
b
gosh> (eq? a (car (cons a b)))
#t
gosh> (eq? b (cdr (cons a b)))
#t

ここで (cons x y) で生成したオブジェクトがセルではない場合を考えてみましょう。もし、そのオブジェクトに car を適用すれば cons の第 1 引数 x を返し、cdr を適用すれば第 2 引数を返すことができれば、セルと同じことが実現できます。

そこで、cons はセルではなくクロージャを返すことにしましょう。クロージャは引数 x, y の値を保持することができます。そして、このクロージャは引数に関数を受け取ることにします。あとは、この関数に引数 x, y を渡して評価すれば car と cdr を実現することができます。

Gauche でプログラムすると次のようになります。

gosh> (define (cons2 x y) (lambda (z) (z x y)))
cons2
gosh> (define (car2 x) (x (lambda (a b) a)))
car2
gosh> (define (cdr2 x) (x (lambda (a b) b)))
cdr2
gosh> (car2 (cons2 'a 'b))
a
gosh> (cdr2 (cons2 'a 'b))
b
gosh> (define a (cons2 1 (cons2 2 (cons2 3 4))))
a
gosh> (car2 a)
1
gosh> (car2 (cdr2 a))
2
gosh> (car2 (cdr2 (cdr2 a)))
3
gosh> (cdr2 (cdr2 (cdr2 a)))
4

lambda はラムダ式 (匿名関数) を表します。関数 cons2 はクロージャを返します。このクロージャは引数 z に関数を受け取り、その関数に x, y を渡して評価します。car2 は引数 x にクロージャを渡して評価し、第 1 引数 a を返します。これで car と同じ動作になります。同様に、cdr2 は引数 x にクロージャを渡して評価し、第 2 引数 b を返します。これで cdr と同じ動作になります。

クロージャをサポートしているプログラミング言語であれば、Lisp / Scheme と同じように cons, car, cdr を作ることができます。電卓プログラムで cons, car, cdr をプログラムすると次のようになります。

リスト ; 連結リストの基本関数

def cons(x, y)
  fn(z) z(x, y) end
end

def car(z)
  z(fn(x, y) x end)
end

def cdr(z)
  z(fn(x, y) y end)
end

それでは実際に試してみましょう。

Calc> def cons(x, y) fn(z) z(x, y) end end
cons
Calc> def car(z) z(fn(x, y) x end) end
car
Calc> def cdr(z) z(fn(x, y) y end) end
cdr
Calc> a = cons(1, 0);
<Function>
Calc> car(a);
1
Calc> cdr(a);
0
Calc> b = cons(2, a);
<Function>
Calc> car(b);
2
Calc> cdr(b);
<Function>
Calc> car(cdr(b));
1

このように、クロージャを使って連結リストを作成することができます。

●空リストとデータ型の判定

ところで、car, cdr, cons は簡単に実装できますが、これだけで連結リストを操作する関数を作るのはちょっと苦しいので、データ型を判定する述語を電卓プログラムに追加します。次のリストを見てください。

リスト : データ型の判定

val True = Integer(1)
val False = Integer(0)

fun isNil(Nil) = True
|   isNil(_) = False

fun isInteger(Integer(_)) = True
|   isInteger(_) = False

fun isFloat(Float(_)) = True
|   isFloat(_) = False

fun isFunction(Func(_)) = True
|   isFunction(_) = False

(* 大域変数 *)
val global_env = ref [("sqrt",  ref (Func(F1(call_real_func1 Math.sqrt)))),

                      ・・・ 省略 ・・・

                      ("print",      ref (Func(F1 print_value))),
                      ("putc",       ref (Func(F1 put_char))),
                      ("isNil",      ref (Func(F1 isNil))),
                      ("isInteger",  ref (Func(F1 isInteger))),
                      ("isFloat",    ref (Func(F1 isFloat))),
                      ("isFunction", ref (Func(F1 isFunction))),
                      ("nil",        ref Nil)]

空リストは Nil で表します。Nil は変数 nil に格納しておきます。データ型を判定する述語は isNil, isInteger, isFloat, isFunction の 4 つです。それぞれ、データが Nil, Integer, Float, Function であれば真 (1) を返し、そうでなければ偽 (0) を返します。

それから、print はデータを表示したあと改行しないで Nil を返すように修正します。putc は文字を出力する関数です。文字は整数値 (アスキーコード) で指定します。また、データを表示する関数 print_value で、Nil は表示しないように修正します。

●リストの表示

それでは、連結リストを操作する関数を作っていきましょう。最初に、連結リストを表示する関数 printlist を作ります。

リスト : 連結リストの表示

def pair(xs) isFunction(xs) end

def null(xs) isNil(xs) end

def printlist(xs)
    putc(40),
    while pair(xs) do
      if pair(car(xs)) or null(car(xs)) then
        printlist(car(xs))
      else
        print(car(xs))
      end,
      if pair(cdr(xs)) then putc(32) end,
      xs = cdr(xs)
    end,
    if not null(xs) then putc(32), putc(46), putc(32), print(xs) end,
    putc(41),
    nil
end

連結リストの表示は Lisp / Scheme の表示に合わせます。リストはカッコで囲って、要素は空白で区切ります。セルの CDR 部がリストでない場合、ドット ( . ) で区切ります。CDR 部が空リストの場合、Nil は表示しません。この仕様をそのままプログラムしたものが printlist です。

最初に、リストを判定する述語 pair と空リストを判定する述語 null を定義します。これは isFunction と isNil を呼び出すだけです。printlist は最初に '(' を表示して、while ループで要素を順番に出力します。このとき、要素 car(xs) がリストまたは空リストであれば、printlist を再帰呼び出しします。これで入れ子のリストも表示することができます。

次に、cdr(xs) がリストであれば、要素を空白で区切るため putc で空白 ' ' を出力します。そして、xs を cdr(xs) に書き換えて処理を繰り返します。ループを終了したら、xs が空リスト Nil でなければ、要素をドットで区切って print で xs を表示します。最後に putc で ')' を表示します。

簡単な実行例を示します。

Calc> a = cons(1, nil);
<Function>
Calc> printlist(a);
(1)
Calc> b = cons(2, a);
<Function>
Calc> printlist(b);
(2 1)
Calc> c = cons(3, b);
<Function>
Calc> printlist(c);
(3 2 1)
Calc> printlist(cons(c, b));
((3 2 1) 2 1)
Calc> printlist(cons(c, cons(b, a)));
((3 2 1) (2 1) 1)
Calc> printlist(cons(1, 2));
(1 . 2)
Calc> printlist(cons(nil, nil));
(())

●リストの生成

次はリストを生成する関数 makelist, iota, tabulate を作ります。

リスト : リストの生成

def makelist0(n, x)
  if n == 0 then
    nil
  else
    cons(x, makelist0(n - 1, x))
  end
end

def makelist(n, x)
  let rec
    iter = fn(n, a)
      if n == 0 then
        a
      else
        iter(n - 1, cons(x, a))
      end
    end
  in
    iter(n, nil)
  end
end

def iota0(n, m)
  if n > m then
    nil
  else
    cons(n, iota0(n + 1, m))
  end
end

def iota(n, m)
  let rec
    iter = fn(m, a)
      if m < n then
        a
      else
        iter(m - 1, cons(m, a))
      end
    end
  in
    iter(m, nil)
  end
end


def tabulate0(f, n, m)
  if n > m then
    nil
  else
    cons(f(n), tabulate0(f, n + 1, m))
  end
end

def tabulate(f, n, m)
  let rec
    iter = fn(m, a)
      if m < n then
        a
      else
        iter(m - 1, cons(f(m), a))
      end
    end
  in
    iter(m, nil)
  end
end

makelist(n, x) は、x を n 個格納したリストを生成します。makelist は makelist0 を末尾再帰に書き直したものです。iota(n, m) は n から m までの整数列を返します。iota は iota0 を末尾再帰に書き直したものです。tabulate(f, n, m) は高階関数で、n から m までの整数列を生成し、その要素に関数 f を適用した結果をリストに格納して返します。つまり、map(f, iota(n, m)) と同じ動作になります。tabulate は tabulate0 を末尾再帰に書き直したものです。

簡単な実行例を示します。

Calc> printlist(makelist(10, 0));
(0 0 0 0 0 0 0 0 0 0)
Calc> printlist(makelist(10, nil));
(() () () () () () () () () ())
Calc> printlist(iota(1, 10));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(tabulate(fn(x) x * 2 end, 1, 10));
(2 4 6 8 10 12 14 16 18 20)

●リストの基本的な操作

次は、リストの基本的な操作関数を定義しましょう。次のリストを見てください。

リスト : リストの基本操作関数

def nth(xs, n)
  if null(xs) then
    nil
  else
    if n == 0 then
      car(xs)
    else
      nth(cdr(xs), n - 1)
    end
  end
end

def length0(xs)
  if null(xs) then
    0
  else
    1 + length0(cdr(xs))
  end
end

def length(xs)
  let rec
    iter = fn(xs, n)
      if null(xs) then
        n
      else
        iter(cdr(xs), n + 1)
      end
    end
  in
    iter(xs, 0)
  end
end

def reverse(xs)
  let rec
    iter = fn(ys, a)
             if null(ys) then
               a
             else
               iter(cdr(ys), cons(car(ys), a))
             end
           end
  in
    iter(xs, nil)
  end

def member(x, ls)
  if null(ls) then
    nil
  else
    if car(ls) == x then
      ls
    else
      member(x, cdr(ls))
    end
  end
end

def append(xs, ys)
  if null(xs) then
    ys
  else
    cons(car(xs), append(cdr(xs), ys))
  end
end

def remove(x, ls)
  if null(ls) then
    nil
  else
    if x == car(ls) then
      remove(x, cdr(ls))
    else
      cons(car(ls), remove(x, cdr(ls)))
    end
  end
end

def take(xs, n)
  if n == 0 or null(xs) then
    nil
  else
    cons(car(xs), take(cdr(xs), n - 1))
  end
end

def drop(xs, n)
  if n == 0 or null(xs) then
    xs
  else
    drop(cdr(xs), n - 1)
  end
end

nth はリストの n 番目の要素を取り出します。リストは 0 から数えるものとします。範囲外は nil を返します。length はリストの長さを返します。lenght は length0 を末尾再帰に書き直したものです。reverse はリストを反転します。これも末尾再帰になります。member はリストから x を探します。見つけた場合はリストを返し、見つからない場合は nil を返します。append は 2 つのリストを連結します。引数 xs のリストはコピーされることに注意してください。remove は x と等しい要素を削除したリストを返します。take はリスト xs の先頭から n 個の要素を取り出します。drop はリスト xs の先頭から n 個の要素を取り除きます。

それでは簡単な実行例を示します。

Calc> a = iota(1, 10);
<Function>
Calc> printlist(a);
(1 2 3 4 5 6 7 8 9 10)
Calc> nth(a, 0);
1
Calc> nth(a, 9);
10
Calc> nth(a, 10);

Calc> length(a);
10
Calc> printlist(reverse(a));
(10 9 8 7 6 5 4 3 2 1)
Calc> printlist(member(1, a));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(member(5, a));
(5 6 7 8 9 10)
Calc> printlist(member(10, a));
(10)
Calc> printlist(member(11, a));
()
Calc> b = iota(11, 20);
<Function>
Calc> printlist(append(a, b));
(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
Calc> printlist(remove(1, a));
(2 3 4 5 6 7 8 9 10)
Calc> printlist(remove(5, a));
(1 2 3 4 6 7 8 9 10)
Calc> printlist(remove(10, a));
(1 2 3 4 5 6 7 8 9)
Calc> printlist(remove(11, a));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(take(a, 5));
(1 2 3 4 5)
Calc> printlist(take(a, 0));
()
Calc> printlist(take(a, 10));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(take(a, 11));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(drop(a, 5));
(6 7 8 9 10)
Calc> printlist(drop(a, 0));
(1 2 3 4 5 6 7 8 9 10)
Calc> printlist(drop(a, 10));
()
Calc> printlist(drop(a, 11));
()

●高階関数

高階関数も簡単に作ることができます。

リスト : 高階関数

def map(f, xs)
  if null(xs) then
    nil
  else 
    cons(f(car(xs)), map(f, cdr(xs)))
  end
end

def filter(f, xs)
  if null(xs) then
    nil
  else
    if f(car(xs)) then
      cons(car(xs), filter(f, cdr(xs)))
    else
      filter(f, cdr(xs))
    end
  end
end

def foldl(f, a, xs)
  if null(xs) then
    a
  else
    foldl(f, f(car(xs), a), cdr(xs))
  end
end

def foldr(f, a, xs)
  if null(xs) then
    a
  else
    f(car(xs), foldr(f, a, cdr(xs)))
  end
end

def foreach(f, ls)
  if pair(ls) then
    f(car(ls)),
    foreach(f, cdr(ls))
  end
end

map はマッピングを、filter はフィルターを、foldl, foldr は畳み込みを行います。foreach は SML/NJ の app と同じで、リストの要素に関数 f を適用しますが、その副作用が目的となります。

簡単な実行例を示します。

Calc> printlist(map(fn(x) x * x end, a));
(1 4 9 16 25 36 49 64 81 100)
Calc> printlist(filter(fn(x) x % 2 == 0 end, a));
(2 4 6 8 10)
Calc> foldl(fn(x, a) x + a end, 0, a);
55
Calc> printlist(foldl(fn(x, a) cons(x, a) end, nil, a));
(10 9 8 7 6 5 4 3 2 1)
Calc> foldr(fn(x, a) x + a end, 0, a);
55
Calc> printlist(foldr(fn(x, a) cons(x, a) end, nil, a));
(1 2 3 4 5 6 7 8 9 10)
Calc> foreach(fn(x) print(x), putc(10) end, a);
1
2
3
4
5
6
7
8
9
10
0

foreach の返り値は if の else 節がないため 0 になります。値を表示したくない場合は nil を返すとよいでしょう。

●等値の判定

電卓プログラムの場合、等値演算子 ==, <> で判定できるのは整数と実数だけです。Lisp / Scheme と同様に、リストとリストの等値を判定する述語 equal があると便利です。次のリストを見てください。

リスト : 等値の判定

def equal(xs, ys)
  if pair(xs) and pair(ys) then
    if equal(car(xs), car(ys)) then
      equal(cdr(xs), cdr(ys))
    else
      0
    end
  else
    if (isInteger(xs) and isInteger(ys)) or
       (isFloat(xs) and isFloat(ys)) then
      xs == ys
    else
      null(xs) and null(ys)
    end
  end
end

等値の判定は簡単です。引数 xs, ys がリストの場合、その要素 car(xs) を equal で比較し、等しい場合は cdr(xs) と cdr(ys) を equal で比較します。要素がリストでない場合、整数と実数はデータ型が同じで、値が等しければ真 (1) を返します。整数、実数でない場合、どちらも空リストであれば真 (1) を返し、そうでなければ、他方がリストになるので偽 (0) を返します。これで入れ子になったリストでも等値を判定することができます。

簡単な実行例を示します。

Calc> equal(cons(1, 2), cons(1, 2));
1
Calc> equal(cons(1, 2), cons(1, 0));
0
Calc> equal(cons(1, 2), cons(1, 2.0));
0
Calc> a = iota(1, 10);
<Function>
Calc> equal(a, a);
1
Calc> b = iota(1, 5);
<Function>
Calc> equal(a, b);
0

●簡単な例題

最後に、リスト操作関数を使った簡単なプログラムを作りましょう。

リスト : 簡単な例題

def zip(xs, ys)
  if null(xs) or null(ys) then
    nil
  else
    cons(cons(car(xs), car(ys)), zip(cdr(xs), cdr(ys)))
  end
end

def flatten(ls)
  if null(ls) then
    nil
  else
    if pair(ls) then
      append(flatten(car(ls)), flatten(cdr(ls)))
    else
      cons(ls, nil)
    end
  end
end

def permutation(n, xs)
  let rec
    perm = fn(m, ys, a)
      if m == n then
        printlist(reverse(a)), putc(10) 
      else
        foreach(fn(x) perm(m + 1, remove(x, ys), cons(x, a)) end, ys)
      end
    end
  in
    perm(0, xs, nil)
  end
end

zip は 2 つのリスト xs, ys を受け取り、それぞれの要素をセルに格納したリストを返します。flatten はリストを平坦化する関数です。permutation はリスト xs から n 個の要素を選ぶ順列をすべて表示します。

簡単な実行例を示します。

Calc> a = iota(1, 8);
<Function>
Calc> b = iota(11, 18);
<Function>
Calc> printlist(zip(a, b));
((1 . 11) (2 . 12) (3 . 13) (4 . 14) (5 . 15) (6 . 16) (7 . 17) (8 . 18))
Calc> printlist(flatten(zip(a, b)));
(1 11 2 12 3 13 4 14 5 15 6 16 7 17 8 18)
Calc> permutation(3, iota(1, 3));
(1 2 3)
(1 3 2)
(2 1 3)
(2 3 1)
(3 1 2)
(3 2 1)
0

リストのマージソートも簡単にプログラムできます。

リスト : マージソート

def merge(xs, ys, pred)
  if null(xs) or null(ys) then
    if null(xs) then ys else xs end
  else
    if pred(car(xs), car(ys)) then
      cons(car(xs), merge(cdr(xs), ys, pred))
    else
      cons(car(ys), merge(xs, cdr(ys), pred))
    end
  end
end

def mergeSort(xs, n, pred)
  if n == 1 then
    cons(car(xs), nil)
  else
    let
      m = n / 2
    in
      merge(mergeSort(xs, m, pred),
            mergeSort(drop(xs, m), n - m, pred),
            pred)
    end
  end
end

merge は 2 つのリストをマージ (併合) し、mergeSort は merge を使ってリストをソートします。

簡単な実行例を示します。

Calc> a = cons(1, cons(3, cons(5, cons(7, nil))));
<Function>
Calc> b = cons(2, cons(4, cons(6, cons(8, nil))));
<Function>
Calc> printlist(a);
(1 3 5 7)
Calc> printlist(b);
(2 4 6 8)
Calc> printlist(merge(a, b, fn(x, y) x < y end));
(1 2 3 4 5 6 7 8)
Calc> a = cons(4, cons(5, cons(7, cons(6, cons(8, cons(3, cons(1, cons(9, cons(2, nil)))))))));
<Function>
Calc> printlist(a);
(4 5 7 6 8 3 1 9 2)
Calc> printlist(mergeSort(a, 9, fn(x, y) x < y end));
(1 2 3 4 5 6 7 8 9)
Calc> printlist(mergeSort(a, 9, fn(x, y) x > y end));
(9 8 7 6 5 4 3 2 1)

●リストの破壊的な修正

ところで、このままではコンスセルの CAR 部と CDR 部を破壊的に修正することはできません。Scheme の関数 set-car!, set-cdr! と同じ動作を実現する場合、cons が返すクロージャに値を書き換える処理を追加します。プログラムは次のようになるでしょう。

リスト : リストの破壊的な修正

def cons(x, y)
  fn(n, v)
    if n < 2 then
      if n == 0 then
        x
      else
        y
      end
    else
      if n == 2 then
        x = v
      else
        y = v
      end
    end
  end
end

def car(z) z(0, 0) end

def cdr(z) z(1, 0) end

def setCar(z, v) z(2, v) end

def setCdr(z, v) z(3, v) end

クロージャの第 1 引数 n で実行する処理を指定します。0 が car, 1 が cdr です。2 が setCar で x の値を引数 v に書き換えます。3 が setCdr で y の値を v に書き換えます。あとは、関数 car, cdr, setCar, setCdr で適切な値を指定してクロージャを呼び出すだけです。あとのプログラムは修正しなくても大丈夫です。

簡単な実行例を示しましょう。

Calc> a = cons(1, 2);
<Function>
Calc> printlist(a);
(1 . 2)
Calc> setCar(a, 10);
10
Calc> printlist(a);
(10 . 2)
Calc> setCdr(a, 20);
20
Calc> printlist(a);
(10 . 20)

リストの破壊的操作の例題として、リストの要素を書き換える書き換える listSet とリストを破壊的に反転する関数 nreverse を作ります。

リスト : リストの破壊的な操作

def listSet(xs, n, v)
  if null(xs) then
    nil
  else
    if n == 0 then
      setCar(xs, v)
    else
      listSet(cdr(xs), n - 1, v)
    end
  end
end

def nreverse(xs)
  let rec
    iter = fn(xs, a)
      if null(xs) then
        a
      else
        let ys = cdr(xs) in
          setCdr(xs, a),
          iter(ys, xs)
        end
      end
    end
  in
    iter(xs, nil)
  end
end

listSet は setCar で指定した位置の要素を書き換えます。nreverse は setCdr でセルの CDR 部を書き換えることでリストを反転しています。

簡単な実行例を示します。

Calc> b = iota(1, 10);
<Function>
Calc> printlist(b);
(1 2 3 4 5 6 7 8 9 10)
Calc> listSet(b, 0, 100);
100
Calc> printlist(b);
(100 2 3 4 5 6 7 8 9 10)
Calc> listSet(b, 5, 200);
200
Calc> printlist(b);
(100 2 3 4 5 200 7 8 9 10)
Calc> listSet(b, 9, 300);
300
Calc> printlist(b);
(100 2 3 4 5 200 7 8 9 300)
Calc> a = iota(1, 10);
<Function>
Calc> b = nreverse(a);
<Function>
Calc> printlist(b);
(10 9 8 7 6 5 4 3 2 1)
Calc> printlist(a);
(1)

●プログラムリスト1

(*
 * calc.sml : 電卓プログラム
 *
 *            Copyright (C) 2012-2021 Makoto Hiroi
 *
 * (1) 四則演算の実装
 * (2) 変数と組み込み関数の追加
 * (3) ユーザー定義関数の追加
 * (4) 論理演算子, 比較演算子, if の追加
 * (5) begin, while の追加
 * (6) 関数を値とし、匿名関数 (クロージャ) と let を追加
 * (7) 空リスト Nil と型述語 (isNil, isInteger, isFloat, isFunction) の追加
 *)

open TextIO

(* 例外 *)
exception Calc_exit
exception Syntax_error of string
exception Calc_run_error of string

(* 演算子の定義 *)
datatype operator = Add | Sub | Mul | Quo | Mod | Assign
                  | NOT | AND | OR 
                  | EQ  | NE  | LT  | GT  | LE  | GE

(* 式の定義 *)
datatype value = Nil                         (* 空を表す値 *)
               | Integer of IntInf.int       (* 整数 *)
               | Float of real               (* 実数 *)
               | Func of func                (* 関数 *)
and func = F1  of value -> value
         | F2  of (value * value) -> value
         | CLO of string list * expr * (string * value ref) list
and expr = Val of value                      (* 値 *)
         | Var of string                     (* 変数 *)
         | Op1 of operator * expr            (* 単項演算子 *)
         | Op2 of operator * expr * expr     (* 二項演算子 *)
         | Ops of operator * expr * expr     (* 短絡演算子 *)
         | Sel of expr * expr * expr         (* if expr then expr else expr end *)
         | Whl of expr * expr                (* while expr do expr end *)
         | Bgn of expr list                  (* begin expr, ... end *)
         | Clo of string list * expr         (* fn (仮引数) body end *)
         | Let of string list * expr list * expr
         | Rec of string list * expr list * expr
         | App of expr * expr list           (* 関数の適用 *)

(* トークンの定義 *)
datatype token = Value of value         (* 値 *)
               | Ident of string        (* 識別子 *)
               | Oper of operator       (* 演算子 *)
               | Lpar | Rpar            (* (, ) *)
               | Semic                  (* ; *)
               | Comma                  (* , *)
               | DEF                    (* def *)
               | END                    (* end *)
               | IF                     (* if *)
               | THEN                   (* then *)
               | ELSE                   (* else *)
               | WHL                    (* while *)
               | DO                     (* do *)
               | BGN                    (* begin *)
               | FN                     (* fn *)
               | LET                    (* let *)
               | IN                     (* in *)
               | REC                    (* rec *)
               | Quit                   (* 終了 *)
               | Others                 (* その他 *)


(* value を real に変換 *)
fun toReal(Float(v)) = v
|   toReal(Integer(v)) = Real.fromLargeInt(v)
|   toReal(_) = raise Calc_run_error("Not Number")

(* 関数を呼び出す *)
fun call_real_func1 f v = Float(f(toReal v))
fun call_real_func2 f (v, w) = Float(f(toReal v, toReal w))

(* 値の表示 *)
fun print_value x =
    case x of
         Nil => Nil
       | Integer(n) => (print(IntInf.toString(n)); Nil)
       | Float(n) => (print(Real.toString(n)); Nil)
       | Func(_) => (print "<Function>"; Nil)

(* 文字の表示 *)
fun put_char(n as Integer(x)) = (
      output1(stdOut, chr(IntInf.toInt(x))); Nil
    )
|   put_char(_) = raise Calc_run_error("Not Integer")

(* 型チェック *)
val True = Integer(1)
val False = Integer(0)

fun isNil(Nil) = True
|   isNil(_) = False

fun isInteger(Integer(_)) = True
|   isInteger(_) = False

fun isFloat(Float(_)) = True
|   isFloat(_) = False

fun isFunction(Func(_)) = True
|   isFunction(_) = False

(* 大域変数 *)
val global_env = ref [("sqrt",  ref (Func(F1(call_real_func1 Math.sqrt)))),
                      ("sin",   ref (Func(F1(call_real_func1 Math.sin)))),
                      ("cos",   ref (Func(F1(call_real_func1 Math.cos)))),
                      ("tan",   ref (Func(F1(call_real_func1 Math.tan)))),
                      ("asin",  ref (Func(F1(call_real_func1 Math.asin)))),
                      ("acos",  ref (Func(F1(call_real_func1 Math.acos)))),
                      ("atan",  ref (Func(F1(call_real_func1 Math.atan)))),
                      ("atan2", ref (Func(F2(call_real_func2 Math.atan2)))),
                      ("exp",   ref (Func(F1(call_real_func1 Math.exp)))),
                      ("pow",   ref (Func(F2(call_real_func2 Math.pow)))),
                      ("ln",    ref (Func(F1(call_real_func1 Math.ln)))),
                      ("log10", ref (Func(F1(call_real_func1 Math.log10)))),
                      ("sinh",  ref (Func(F1(call_real_func1 Math.sinh)))),
                      ("cosh",  ref (Func(F1(call_real_func1 Math.cosh)))),
                      ("tanh",  ref (Func(F1(call_real_func1 Math.tanh)))),
                      ("print",      ref (Func(F1 print_value))),
                      ("putc",       ref (Func(F1 put_char))),
                      ("isNil",      ref (Func(F1 isNil))),
                      ("isInteger",  ref (Func(F1 isInteger))),
                      ("isFloat",    ref (Func(F1 isFloat))),
                      ("isFunction", ref (Func(F1 isFunction))),
                      ("nil",        ref Nil)]

(* 探索 *)
fun lookup name =
    let
      fun iter [] = NONE
      |   iter ((x as (n, _))::xs) =
          if n = name then SOME x else iter xs
    in
      iter(!global_env)
    end

(* 追加 *)
fun update(name, value) = 
    global_env := (name, ref value)::(!global_env)

(* 切り出したトークンを格納するバッファ *)
val tokenBuff = ref Others

(* 整数の切り出し *)
fun get_number s =
    let
      val buff = ref []
      fun get_numeric() =
          let val c = valOf(lookahead s) in
            if Char.isDigit(c) then (
              buff := valOf(input1 s) :: (!buff);
              get_numeric()
            ) else ()
          end
      fun check_float(c) =
          case c of
            #"." => true
          | #"e" => true
          | #"E" => true
          | _ => false
    in
      get_numeric();    (* 整数部の取得 *)
      if check_float(valOf(lookahead s)) then (
        if valOf(lookahead s) = #"." then (
          (* 小数部の取得 *)
          buff := valOf(input1 s) :: (!buff);
          get_numeric()
        ) else ();
        if Char.toUpper(valOf(lookahead s)) = #"E" then (
          (* 指数形式 *)
          buff := valOf(input1 s) :: (!buff);
          let val c = valOf(lookahead s) in
            if c = #"+" orelse c = #"-" then
              buff := (valOf(input1 s)) :: (!buff)
            else ()
          end;
          get_numeric()
        ) else ();
        tokenBuff := Value(Float(valOf(Real.fromString(implode(rev (!buff))))))
      ) else
        tokenBuff := Value(Integer(valOf(IntInf.fromString(implode(rev (!buff))))))
    end

(* 識別子の切り出し *)
fun get_ident s =
    let fun iter a =
      if Char.isAlphaNum(valOf(lookahead s)) then
        iter ((valOf(input1 s)) :: a)
      else Ident(implode(rev a))
    in
      iter []
    end

(* トークンの切り出し *)
fun get_token s =
    let val c = valOf(lookahead s) in
      if Char.isSpace(c) then (input1 s; get_token s)
      else if Char.isDigit(c) then get_number s
      else if Char.isAlpha(c) then
        let val (id as Ident(name)) = get_ident s in
          tokenBuff := (
            case name of 
                 "quit" => Quit
               | "def"  => DEF
               | "end"  => END
               | "not"  => Oper(NOT)
               | "and"  => Oper(AND)
               | "or"   => Oper(OR)
               | "if"   => IF
               | "then" => THEN
               | "else" => ELSE
               | "while" => WHL
               | "do"    => DO
               | "begin" => BGN
               | "fn"    => FN
               | "let"   => LET
               | "in"    => IN
               | "rec"   => REC
               | _       => id
          )
        end
      else (
        input1 s; (* s から c を取り除く *)
        tokenBuff := (case c of
            #"+" => Oper(Add)
          | #"-" => Oper(Sub)
          | #"*" => Oper(Mul)
          | #"/" => Oper(Quo)
          | #"%" => Oper(Mod)
          | #"=" => (case valOf(lookahead s) of
                          #"=" => (input1 s; Oper(EQ))
                        | _ => Oper(Assign))
          | #"!" => (case valOf(lookahead s) of
                          #"=" => (input1 s; Oper(NE))
                        | _ => Oper(NOT))
          | #"<" => (case valOf(lookahead s) of
                          #"=" => (input1 s; Oper(LE))
                        | _ => Oper(LT))
          | #">" => (case valOf(lookahead s) of
                          #"=" => (input1 s; Oper(GE))
                        | _ => Oper(GT))
          | #"(" => Lpar
          | #")" => Rpar
          | #";" => Semic
          | #"," => Comma
          | _    => Others
        )
      )
    end

(* 構文木の組み立て *)
fun expression s =
    let
      fun iter v =
        case !tokenBuff of
             Oper(Assign) => (
               case v of
                    Var(_) => (get_token s; Op2(Assign, v, expression s))
                  | _ => raise Syntax_error("invalid assign form")
             )
           | _ => v
    in
      iter(expr1 s)
    end
(* 論理演算子 and, or の処理 *)
and expr1 s =
    let
      fun iter v =
          case !tokenBuff of
               Oper(AND) => (get_token s; iter(Ops(AND, v, expr2 s)))
             | Oper(OR)  => (get_token s; iter(Ops(OR,  v, expr2 s)))
             | _ => v
    in
      iter(expr2 s)
    end
(* 比較演算子の処理 *)
and expr2 s =
    let
      fun iter v =
          case !tokenBuff of
               Oper(EQ) => (get_token s; iter(Op2(EQ, v, expr3 s)))
             | Oper(NE) => (get_token s; iter(Op2(NE, v, expr3 s)))
             | Oper(LT) => (get_token s; iter(Op2(LT, v, expr3 s)))
             | Oper(GT) => (get_token s; iter(Op2(GT, v, expr3 s)))
             | Oper(LE) => (get_token s; iter(Op2(LE, v, expr3 s)))
             | Oper(GE) => (get_token s; iter(Op2(GE, v, expr3 s)))
             | _ => v
    in
      iter(expr3 s)
    end
and expr3 s =
    let
      fun iter v =
          case !tokenBuff of
            Oper(Add) => (get_token s; iter(Op2(Add, v, term s)))
          | Oper(Sub) => (get_token s; iter(Op2(Sub, v, term s)))
          | _ => v
    in
      iter (term s)
    end
and term s =
    let
      fun iter v =
          case !tokenBuff of
            Oper(Mul) => (get_token s; iter(Op2(Mul, v, factor s)))
          | Oper(Quo) => (get_token s; iter(Op2(Quo, v, factor s)))
          | Oper(Mod) => (get_token s; iter(Op2(Mod, v, factor s)))
          | _ => v
    in
      iter (factor s)
    end
and factor s =
    case !tokenBuff of
      Lpar => (
          get_token s;
          let
            val v = expression s
          in
            case !tokenBuff of
              Rpar => (get_token s; v)
            | _ => raise Syntax_error("')' expected")
          end
        )
    | Value(n) => (get_token s; Val(n))
    | Quit => raise Calc_exit
    | IF => (get_token s; make_sel s)
    | WHL => (get_token s; make_while s)
    | BGN => (get_token s; make_begin s)
    | FN  => (get_token s; make_clo s)
    | LET => (get_token s; make_let s)
    | Oper(NOT) => (get_token s; Op1(NOT, factor s))
    | Oper(Sub) => (get_token s; Op1(Sub, factor s))
    | Oper(Add) => (get_token s; Op1(Add, factor s))
    | Ident(name) => (
        get_token s;
        case !tokenBuff of
             Lpar =>  App(Var(name), get_argument s)
           | _ => Var(name)
      )
    | _ => raise Syntax_error("unexpected token")
(* カンマで区切られた式を取得 *)
and get_comma_list(s, a) =
    let val v = expression s in
      case !tokenBuff of
           Comma => (get_token s; get_comma_list(s, v::a))
         | _ => rev(v::a)
    end
(* 引数の取得 *)
and get_argument s =
    case !tokenBuff of
         Lpar => (get_token s;
                  case !tokenBuff of
                       Rpar => (get_token s; [])
                     | _ => let val args = get_comma_list(s, []) in
                              case !tokenBuff of
                                   Rpar => (get_token s; args)
                                 | _ => raise Syntax_error("unexpected token")
                            end)
       | _ => raise Syntax_error("'(' expected")
(* 仮引数の取得 *)
and get_parameter s =
    let val parm = get_argument s in
      map (fn x => case x of
                        Var(name) => name
                      | _ => raise Syntax_error("bad parameter"))
          parm
    end
(* if *)
and make_sel s =
    let val test_form = expression s in
      case !tokenBuff of
           THEN => (
             get_token s;
             let val then_form = get_comma_list(s, []) in
               case !tokenBuff of
                    ELSE => (
                      get_token s;
                      let val else_form = get_comma_list(s, []) in
                        case !tokenBuff of
                             END => (get_token s;
                                     Sel(test_form, Bgn(then_form), Bgn(else_form)))
                           | _ => raise Syntax_error("end expected")
                      end
                    )
                  | END => (get_token s;
                            Sel(test_form, Bgn(then_form), Val(False)))
                  | _ => raise Syntax_error("else or end expected")
             end
           )
         | _ => raise Syntax_error("then expected")
    end
(* while *)
and make_while s = 
    let val test_form = expression s in
      case !tokenBuff of
           DO => (get_token s; Whl(test_form, make_begin s))
         | _ => raise Syntax_error("do expected")
    end
(* begin *)
and make_begin s =
    let
      val body = get_comma_list(s, [])
    in
      case !tokenBuff of
           END => (get_token s; Bgn(body))
         | _ => raise Syntax_error("end expected")
    end
(* closure *)
and make_clo s =
    let
      val args = get_parameter s
      val body = make_begin s
    in
      case !tokenBuff of
           Lpar => App(Clo(args, body), get_argument s)
         | _ => Clo(args, body)
    end
and make_let s =
    let
      fun iter(a, b) =
          case !tokenBuff of
               IN => (get_token s; (a, b, make_begin s))
             | Comma => (get_token s; iter(a, b))
             | _ => let val e1 = expression s in
                      case e1 of
                           Op2(Assign, Var(x), e2) => iter(x::a, e2::b)
                         | _ => raise Syntax_error("invalid let form")
                    end
    in
      case !tokenBuff of
           REC => (get_token s; Rec(iter([], [])))
         | _ => Let(iter([], []))
    end

(* 変数束縛 *)
fun add_binding([], _, a) = a
|   add_binding(_, [], _) = raise Calc_run_error("not enough argument")
|   add_binding(name::ps, x::xs, a) = add_binding(ps, xs, (name, ref x)::a)

(* 変数を求める *)
fun get_var(name, []) = lookup(name)
|   get_var(name, (x as (n, _))::xs) =
    if name = n then SOME x else get_var(name, xs)

(* 真偽のチェック *)
fun isTrue(Float(v))  = Real.!=(v, 0.0)
|   isTrue(Integer(v)) = v <> 0
|   isTrue(Nil) = false
|   isTrue(_) = true

(* 演算子の評価 *)
fun eval_op(op1, op2, v, w) =
    case (v, w) of
         (Integer(n), Integer(m)) => Integer(op1(n, m))
       | (Integer(n), Float(m)) => Float(op2(Real.fromLargeInt(n), m))
       | (Float(n), Integer(m)) => Float(op2(n, Real.fromLargeInt(m)))
       | (Float(n), Float(m)) => Float(op2(n, m))
       | (_, _) => raise Calc_run_error("Not Number")

fun eval_op_int(op1, v, w) =
    case (v, w) of
         (Integer(n), Integer(m)) => Integer(op1(n, m))
       | (_, _) => raise Calc_run_error("Not Integer")

(* 比較演算子の評価 *)
fun eval_comp(op1, op2, v, w) =
    case (v, w) of
         (Integer(n), Integer(m)) =>
         if op1(n, m) then True else False
       | (Integer(n), Float(m)) =>
         if op2(Real.fromLargeInt(n), m) then True else False
       | (Float(n), Integer(m)) =>
         if op2(n, Real.fromLargeInt(m)) then True else False
       | (Float(n), Float(m)) =>
         if op2(n, m) then True else False
       | (_, _) => raise Calc_run_error("Not Number")

(* 式の評価 *)
fun eval_expr(Val(n), _) = n
|   eval_expr(Var(name), env) = (
      case get_var(name, env) of
           NONE => raise Calc_run_error("Unbound variable: " ^ name)
         | SOME (_, ref v) => v
    )
|   eval_expr(Op2(Assign, expr1, expr2), env) =
    let
      val w = eval_expr(expr2, env)
    in
      case expr1 of
           Var(name) => (case get_var(name, env) of
                              NONE => (update(name, w); w)
                            | SOME (_, v) => (v := w; w) )
         | _ => raise Calc_run_error("Illegal assign form")
    end
|   eval_expr(Op2(op2, expr1, expr2), env) = 
    let
      val v = eval_expr(expr1, env)
      val w = eval_expr(expr2, env)
    in
      case op2 of
           Add => eval_op(op +, op +, v, w)
         | Sub => eval_op(op -, op -, v, w)
         | Mul => eval_op(op *, op *, v, w)
         | Quo => eval_op(op div, op /, v, w)
         | Mod => eval_op_int(op mod,  v, w)
         | EQ => eval_comp(op =, Real.==, v, w)
         | NE => eval_comp(op <>, Real.!=, v, w)
         | LT => eval_comp(op <, op <, v, w)
         | GT => eval_comp(op >, op >, v, w)
         | LE => eval_comp(op <=, op <=, v, w)
         | GE => eval_comp(op >=, op >=, v, w)
         | _  => raise Calc_run_error("Illegal operator")
    end
|   eval_expr(Op1(op1, expr1), env) =
    let
      val v = eval_expr(expr1, env)
    in
      case (op1, v) of
           (Add, _) => v
         | (Sub, Integer(n)) => Integer(~n)
         | (Sub, Float(n)) => Float(~n)
         | (NOT, _) => if isTrue(v) then False else True
         | _ => raise Calc_run_error("Illegal expression")
    end
|   eval_expr(Ops(ops, expr1, expr2), env) =
    let val v  = eval_expr(expr1, env) in
      case ops of
           AND => if isTrue(v) then eval_expr(expr2, env) else v
         | OR  => if isTrue(v) then v else eval_expr(expr2, env)
         | _   => raise Calc_run_error("Illegal operator")
    end
|   eval_expr(Sel(expr_c, expr_t, expr_e), env) =
    if isTrue(eval_expr(expr_c, env))
    then eval_expr(expr_t, env) else eval_expr(expr_e, env)
|   eval_expr(App(expr, args), env) = (
      case eval_expr(expr, env) of
           Func f =>
             let
               val vs = map (fn e => eval_expr(e, env)) args
             in
               case f of
                    F1 f1 => f1(hd vs)
                  | F2 f2 => f2(hd vs, hd (tl vs))
                  | CLO(parm, body, clo) =>
                    eval_expr(body, add_binding(parm, vs, clo))
             end
         | _ => raise Calc_run_error("Not function")
    )
|   eval_expr(Whl(expr_c, expr_b), env) = (
      while isTrue(eval_expr(expr_c, env)) do eval_expr(expr_b, env);
      False
    )
|   eval_expr(Bgn(xs), env) =
    let
      fun iter [] = raise Calc_run_error("ivalid begin form")
      |   iter [x] = eval_expr(x, env)
      |   iter (x::xs) = (eval_expr(x, env); iter(xs))
    in
      iter(xs)
    end
|   eval_expr(Clo(args, expr), env) = Func(CLO(args, expr, env))
|   eval_expr(Let(parm, args, body), env) =
    eval_expr(body, 
              ListPair.foldl (fn(n, e, a) => (n, ref (eval_expr(e, env)))::a)
                             env
                             (parm, args))
|   eval_expr(Rec(parm, args, body), env) =
    let
      val new_env = foldl (fn(x, a) => (x, ref Nil)::a) env parm
    in
      ListPair.app (fn(p, e) =>
                      case get_var(p, new_env) of
                           NONE => raise Calc_run_error("let rec error")
                         | SOME (_, v) => v := eval_expr(e, new_env))
                   (parm, args);
      eval_expr(body, new_env)
    end

(* 実行 *)
fun toplevel s = (
    get_token s;
    case !tokenBuff of
      DEF => (
        get_token s;
        case !tokenBuff of
             Ident(name) => (
               get_token s;
               let
                 val a = get_parameter s
                 val b = get_comma_list(s, [])
               in
                 case !tokenBuff of
                      END => (update(name, Func(CLO(a, Bgn(b), [])));
                              print (name ^ "\n"))
                    | _ => raise Syntax_error("end expected")
               end
             )
           | _ => raise Syntax_error("ivalid def form")
    )
    | _ => let val result = expression s in
        case !tokenBuff of
          Semic => ()
        | Quit  => raise Calc_exit
        | _ => raise Syntax_error("unexpected token");
        print_value(eval_expr(result, []));
        print "\n"
      end
)

(* ファイルのロード *)
fun load_library(filename) =
    let
      val a = openIn(filename)
    in
      (while true do toplevel(a)) handle
          Option => ()
        | Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
        | Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
        | Div => print("ERROR: divide by zero\n")
        | err => raise err;
      closeIn(a)
    end

fun calc(filename) = (
    if filename <> "" then load_library(filename) else ();
    while true do (
      print "Calc> ";
      flushOut(stdOut);
      toplevel(stdIn) handle 
        Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
      | Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
      | Div => print("ERROR: divide by zero\n")
      | err => raise err;
      inputLine(stdIn)
    )
)

●プログラムリスト2

リスト : 連結リストライブラリ

def cons(x, y)
  fn(n, v)
    if n < 2 then
      if n == 0 then
        x
      else
        y
      end
    else
      if n == 2 then
        x = v
      else
        y = v
      end
    end
  end
end

def car(z) z(0, 0) end

def cdr(z) z(1, 0) end

def setCar(z, v) z(2, v) end

def setCdr(z, v) z(3, v) end

def pair(xs) isFunction(xs) end

def null(xs) isNil(xs) end

def nth(xs, n)
  if null(xs) then
    nil
  else
    if n == 0 then
      car(xs)
    else
      nth(cdr(xs), n - 1)
    end
  end
end

def length0(xs)
  if null(xs) then
    0
  else
    1 + length0(cdr(xs))
  end
end

def length(xs)
  let rec
    iter = fn(xs, n)
      if null(xs) then
        n
      else
        iter(cdr(xs), n + 1)
      end
    end
  in
    iter(xs, 0)
  end
end

def reverse(xs)
  let rec
    iter = fn(ys, a)
             if null(ys) then
               a
             else
               iter(cdr(ys), cons(car(ys), a))
             end
           end
  in
    iter(xs, nil)
  end
end

def member(x, ls)
  if null(ls) then
    nil
  else
    if car(ls) == x then
      ls
    else
      member(x, cdr(ls))
    end
  end
end

def append(xs, ys)
  if null(xs) then
    ys
  else
    cons(car(xs), append(cdr(xs), ys))
  end
end

def remove(x, ls)
  if null(ls) then
    nil
  else
    if x == car(ls) then
      remove(x, cdr(ls))
    else
      cons(car(ls), remove(x, cdr(ls)))
    end
  end
end

def map(f, xs)
  if null(xs) then
    nil
  else 
    cons(f(car(xs)), map(f, cdr(xs)))
  end
end

def filter(f, xs)
  if null(xs) then
    nil
  else
    if f(car(xs)) then
      cons(car(xs), filter(f, cdr(xs)))
    else
      filter(f, cdr(xs))
    end
  end
end

def foldl(f, a, xs)
  if null(xs) then
    a
  else
    foldl(f, f(car(xs), a), cdr(xs))
  end
end

def foldr(f, a, xs)
  if null(xs) then
    a
  else
    f(car(xs), foldr(f, a, cdr(xs)))
  end
end

def foreach(f, ls)
  if pair(ls) then
    f(car(ls)),
    foreach(f, cdr(ls))
  end
end

def zip(xs, ys)
  if null(xs) or null(ys) then
    nil
  else
    cons(cons(car(xs), car(ys)), zip(cdr(xs), cdr(ys)))
  end
end

def flatten(ls)
  if null(ls) then
    nil
  else
    if pair(ls) then
      append(flatten(car(ls)), flatten(cdr(ls)))
    else
      cons(ls, nil)
    end
  end
end

def take(xs, n)
  if n == 0 or null(xs) then
    nil
  else
    cons(car(xs), take(cdr(xs), n - 1))
  end
end

def drop(xs, n)
  if n == 0 or null(xs) then
    xs
  else
    drop(cdr(xs), n - 1)
  end
end

def makelist0(n, x)
  if n == 0 then
    nil
  else
    cons(x, makelist0(n - 1, x))
  end
end

def makelist(n, x)
  let rec
    iter = fn(n, a)
      if n == 0 then
        a
      else
        iter(n - 1, cons(x, a))
      end
    end
  in
    iter(n, nil)
  end
end

def iota0(n, m)
  if n > m then
    nil
  else
    cons(n, iota0(n + 1, m))
  end
end

def iota(n, m)
  let rec
    iter = fn(m, a)
      if m < n then
        a
      else
        iter(m - 1, cons(m, a))
      end
    end
  in
    iter(m, nil)
  end
end


def tabulate0(f, n, m)
  if n > m then
    nil
  else
   cons(f(n), tabulate0(f, n + 1, m))
  end
end

def tabulate(f, n, m)
  let rec
    iter = fn(m, a)
      if m < n then
        a
      else
        iter(m - 1, cons(f(m), a))
      end
    end
  in
    iter(m, nil)
  end
end

def equal(xs, ys)
  if pair(xs) and pair(ys) then
    if equal(car(xs), car(ys)) then
      equal(cdr(xs), cdr(ys))
    else
      0
    end
  else
    if (isInteger(xs) and isInteger(ys)) or
       (isFloat(xs) and isFloat(ys)) then
      xs == ys
    else
      null(xs) and null(ys)
    end
  end
end

def printlist(xs)
    putc(40),
    while pair(xs) do
      if pair(car(xs)) or null(car(xs)) then
        printlist(car(xs))
      else
        print(car(xs))
      end,
      if pair(cdr(xs)) then putc(32) end,
      xs = cdr(xs)
    end,
    if not null(xs) then putc(32), putc(46), putc(32), print(xs) end,
    putc(41),
    nil
end

def permutation(n, xs)
  let rec
    perm = fn(m, ys, a)
      if m == n then
        printlist(reverse(a)), putc(10) 
      else
        foreach(fn(x) perm(m + 1, remove(x, ys), cons(x, a)) end, ys)
      end
    end
  in
    perm(0, xs, nil)
  end
end

def merge(xs, ys, pred)
  if null(xs) or null(ys) then
    if null(xs) then ys else xs end
  else
    if pred(car(xs), car(ys)) then
      cons(car(xs), merge(cdr(xs), ys, pred))
    else
      cons(car(ys), merge(xs, cdr(ys), pred))
    end
  end
end

def mergeSort(xs, n, pred)
  if n == 1 then
    cons(car(xs), nil)
  else
    let
      m = n / 2
    in
      merge(mergeSort(xs, m, pred),
            mergeSort(drop(xs, m), n - m, pred),
            pred)
    end
  end
end

def listSet(xs, n, v)
  if null(xs) then
    nil
  else
    if n == 0 then
      setCar(xs, v)
    else
      listSet(cdr(xs), n - 1, v)
    end
  end
end

def nreverse(xs)
  let rec
    iter = fn(xs, a)
      if null(xs) then
        a
      else
        let ys = cdr(xs) in
          setCdr(xs, a),
          iter(ys, xs)
        end
      end
    end
  in
    iter(xs, nil)
  end
end

初版 2012 年 8 月 26 日
改訂 2021 年 5 月 30 日

Copyright (C) 2012-2021 Makoto Hiroi
All rights reserved.

[ PrevPage | SML/NJ | NextPage ]