昨日の続き(二分木とバラの木)

木構造の定義

# type 'a tree = Lf | Br of 'a * 'a tree * 'a tree;;
type 'a tree = Lf | Br of 'a * 'a tree * 'a tree
# type 'a rosetree = RLf | RBr of 'a * 'a rosetree list;;
type 'a rosetree = RLf | RBr of 'a * 'a rosetree list
# let rtree =
    RBr ("a", [
      RBr ("b", [
        RBr ("c", [RLf]);
        RLf;
        RBr ("d", [RLf])]);
      RBr ("e", [RLf]);
      RBr ("f", [RLf])]);;
val rtree : string rosetree =
  RBr ("a",
   [RBr ("b", [RBr ("c", [RLf]); RLf; RBr ("d", [RLf])]); RBr ("e", [RLf]);
    RBr ("f", [RLf])])

複数の枝を持つrosetreeを定義した。
rosetree -> tree の変換

# let rec tree_of_rtree = function
    RLf -> Br (None, Lf, Lf)
  | RBr (a, rtrees) -> Br (Some a, tree_of_rtreelist rtrees, Lf)
  and tree_of_rtreelist = function
    [] -> Lf
  | rtree :: rest -> let Br (a, left, right) = tree_of_rtree rtree in
                     Br (a, left, tree_of_rtreelist rest);;
            Characters 201-220:
Warning P: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
Lf
    | rtree :: rest -> let Br (a, left, right) = tree_of_rtree rtree in
                           ^^^^^^^^^^^^^^^^^^^
val tree_of_rtree : 'a rosetree -> 'a option tree = <fun>
val tree_of_rtreelist : 'a rosetree list -> 'a option tree = <fun>
# let ctree = tree_of_rtree rtree;;
- : string option tree =
Br (Some "a",
 Br (Some "b",
  Br (Some "c", Br (None, Lf, Lf),
   Br (None, Lf, Br (Some "d", Br (None, Lf, Lf), Lf))),
  Br (Some "e", Br (None, Lf, Lf), Br (Some "f", Br (None, Lf, Lf), Lf))),
 Lf)
# 

tree -> rosetree の変換

# let rec rtree_of_tree = function
    Lf -> RLf
  | Br (None, _, _) -> RLf
  | Br (Some a, left, _) -> RBr (a, rtreelist_of_tree left)
  and rtreelist_of_tree = function
    Lf -> []
  | Br (_, left, right) as t -> rtree_of_tree t :: rtreelist_of_tree right;;
val rtree_of_tree : 'a option tree -> 'a rosetree = <fun>
val rtreelist_of_tree : 'a option tree -> 'a rosetree list = <fun>
# rtree_of_tree ctree;;
- : string rosetree =
RBr ("a",
 [RBr ("b", [RBr ("c", [RLf]); RLf; RBr ("d", [RLf])]); RBr ("e", [RLf]);
  RBr ("f", [RLf])])

テスト

# rtree_of_tree (tree_of_rtree rtree);;
- : string rosetree =
RBr ("a",
 [RBr ("b", [RBr ("c", [RLf]); RLf; RBr ("d", [RLf])]); RBr ("e", [RLf]);
  RBr ("f", [RLf])])
# tree_of_rtree (rtree_of_tree ctree);;
- : string option tree =
Br (Some "a",
 Br (Some "b",
  Br (Some "c", Br (None, Lf, Lf),
   Br (None, Lf, Br (Some "d", Br (None, Lf, Lf), Lf))),
  Br (Some "e", Br (None, Lf, Lf), Br (Some "f", Br (None, Lf, Lf), Lf))),
 Lf)

再帰的データ型(二分木)

さっそくデータ型を定義。大きさと深さを求める関数も定義。

# type 'a tree = Lf | Br of 'a * 'a tree * 'a tree;;
type 'a tree = Lf | Br of 'a * 'a tree * 'a tree
# let rec size = function
    Lf -> 0
  | Br (_, left, right) -> 1 + size left + size right;;
val size : 'a tree -> int = <fun>
# let rec depth = function
    Lf -> 0
  | Br (_, left, right) -> 1 + max (depth left) (depth right);;
val depth : 'a tree -> int = <fun>
# let tree = Br (1, Br (2, Br (4, Lf, Lf),
                           Br (5, Lf, Lf)),
                    Br (3, Br (6, Lf, Lf),
                           Br (7, Lf, Lf)));;
val tree : int tree =
  Br (1, Br (2, Br (4, Lf, Lf), Br (5, Lf, Lf)),
   Br (3, Br (6, Lf, Lf), Br (7, Lf, Lf)))
# size tree;;
- : int = 7
# depth tree;;
- : int = 3

このような木を生成する関数を書いてみる。

# let rec comptree x = function
    0 -> Lf
  | n -> Br (x, comptree x (n-1), comptree x (n-1));;
val comptree : 'a -> int -> 'a tree = <fun>
# comptree 'a' 3;;
- : char tree =
Br ('a', Br ('a', Br ('a', Lf, Lf), Br ('a', Lf, Lf)),
 Br ('a', Br ('a', Lf, Lf), Br ('a', Lf, Lf)))
# let comptree' n =
    let rec get_tree x = function
      0 -> Lf
    | n -> Br (x, get_tree (2*x) (n-1), get_tree (2*x+1) (n-1))
    in
    get_tree 1 n;;
val comptree' : int -> int tree = <fun>
# comptree' 3;;
- : int tree =
Br (1, Br (2, Br (4, Lf, Lf), Br (5, Lf, Lf)),
 Br (3, Br (6, Lf, Lf), Br (7, Lf, Lf)))

二分木の要素を列挙する関数

# let tree = comptree' 3;;
val tree : int tree =
  Br (1, Br (2, Br (4, Lf, Lf), Br (5, Lf, Lf)),
   Br (3, Br (6, Lf, Lf), Br (7, Lf, Lf)))
# let preorder tree = 
    let rec preord t l =
      match t with
        Lf -> l
      | Br (x, left, right) -> x :: (preord left (preord right l))
    in
    preord tree [];;
val preorder : 'a tree -> 'a list = <fun>
# preorder tree;;
- : int list = [1; 2; 4; 5; 3; 6; 7]
# let inorder tree = 
    let rec inord t l =
      match t with
        Lf -> l
      | Br (x, left, right) -> inord left (x :: inord right l)
    in
    inord tree [];;
val inorder : 'a tree -> 'a list = <fun>
# inorder tree;;
- : int list = [4; 2; 5; 1; 6; 3; 7]
# let postorder tree =
    let rec postord t l =
      match t with
        Lf -> l
      | Br (x, left, right) -> postord left (postord right (x :: l))
    in postord tree [];;
val postorder : 'a tree -> 'a list = <fun>
# postorder tree;;
- : int list = [4; 5; 2; 6; 7; 3; 1]

二分木を左右反転させる関数

# let rec reflect = function
      Lf -> Lf
    | Br (x, left, right) -> Br (x, reflect right, reflect left);;
val reflect : 'a tree -> 'a tree = <fun>
# reflect tree;;
- : int tree =
Br (1, Br (3, Br (7, Lf, Lf), Br (6, Lf, Lf)),
 Br (2, Br (5, Lf, Lf), Br (4, Lf, Lf)))
# preorder (reflect tree);;
- : int list = [1; 3; 7; 6; 2; 5; 4]
# inorder (reflect tree);;
- : int list = [7; 3; 6; 1; 5; 2; 4]
# postorder (reflect tree);;
- : int list = [7; 6; 3; 5; 4; 2; 1]

これらより、以下が導かれる。

  • preorder (reflect tree) = reverse (postorder tree)
  • inorder (reflect tree) = reverse (inorder tree)
  • postorder (reflect tree) = reverse (preorder tree)

再帰的データ型

さらに引き続きOCaml勉強中。この本を使って勉強しています。

プログラミング in OCaml ~関数型プログラミングの基礎からGUI構築まで~

プログラミング in OCaml ~関数型プログラミングの基礎からGUI構築まで~


各章の終わりにちょっと難しめの練習問題がついていていい感じ。

今回は、自然数を再帰的に定義してみました。λ式による自然数の定義ってのを前にみたことあるけど、それに似たような感じかな。

# type nat = Zero | OneMoreThan of nat;;
type nat = Zero | OneMoreThan of nat
# let rec add m n =
    match m with Zero -> n | OneMoreThan m' -> OneMoreThan (add m' n);;
val add : nat -> nat -> nat = <fun>
# let zero = Zero;;
val zero : nat = Zero
# let one = OneMoreThan Zero;;
val one : nat = OneMoreThan Zero
# let two = add one one;;
val two : nat = OneMoreThan (OneMoreThan Zero)
# let three = add two one;;
val three : nat = OneMoreThan (OneMoreThan (OneMoreThan Zero))
# let four = add three one;;
val four : nat = OneMoreThan (OneMoreThan (OneMoreThan (OneMoreThan Zero)))
# let five = add four one;;
val five : nat =
  OneMoreThan (OneMoreThan (OneMoreThan (OneMoreThan (OneMoreThan Zero))))

足し算といろんな自然数を定義した。次はかけ算。

# let rec mul m n =
    match m with 
      Zero -> Zero
    | OneMoreThan Zero -> n
    | OneMoreThan m' -> add n (mul m' n);;
val mul : nat -> nat -> nat = <fun>
# mul five four;;
- : nat =
OneMoreThan
 (OneMoreThan
   (OneMoreThan
     (OneMoreThan
       (OneMoreThan
         (OneMoreThan
           (OneMoreThan
             (OneMoreThan
               (OneMoreThan
                 (OneMoreThan
                   (OneMoreThan
                     (OneMoreThan
                       (OneMoreThan
                         (OneMoreThan
                           (OneMoreThan
                             (OneMoreThan
                               (OneMoreThan
                                 (OneMoreThan
                                   (OneMoreThan (OneMoreThan Zero)))))))))))))))))))
# mul five zero;;
- : nat = Zero
# mul three two;;
- : nat =
OneMoreThan
 (OneMoreThan (OneMoreThan (OneMoreThan (OneMoreThan (OneMoreThan Zero)))))

とんでもないことになったw
慌ててnatをintに変換する関数を作った。

# let int_of_nat n =
    let rec get_num nt it =
      match nt with
        Zero -> it
      | OneMoreThan nt' -> get_num nt' (it+1)
    in
    get_num n 0;;
            val int_of_nat : nat -> int = <fun>
# int_of_nat (mul four five);;
- : int = 20
# int_of_nat (mul five (add five (add five five)));;
- : int = 75

ちゃんと動いているみたい。λ式で書かれるより、やっぱりプログラムになった方が分かりやすい。
次は引き算。

# let rec monus m n =
    match (m, n) with
      (Zero, _) -> Zero
    | (_, Zero) -> m
    | (OneMoreThan m', OneMoreThan n') -> monus m' n';;
val monus : nat -> nat -> nat = <fun>
# int_of_nat (monus four three);;
- : int = 1
# int_of_nat (monus five one);;
- : int = 4
# int_of_nat (monus two five);;
- : int = 0
# int_of_nat (monus two two);;
- : int = 0
# int_of_nat (monus one one);;
- : int = 0

自然数の範囲なので、引く数が引かれる数よりも大きい場合は0を返します。
このとき、解無しを返すようにしてみます。そのために、まずはオプション型を定義して、引き算の関数を書き換えます。

# type 'a option = None | Some of 'a;;
type 'a option = None | Some of 'a
# let rec minus m n =
  match (m, n) with
    (_, Zero) -> Some (m)
  | (Zero, _) -> None
  | (OneMoreThan m', OneMoreThan n') -> minus m' n';;
val minus : nat -> nat -> nat option = <fun>
# let string_of_nat_option = function
    None -> "None"
  | Some n -> string_of_int (int_of_nat n);;
val string_of_nat_option : nat option -> string = <fun>
# string_of_nat_option (minus five four);;
- : string = "1"
# string_of_nat_option (minus five five);;
- : string = "0"
# string_of_nat_option (minus four five);;
- : string = "None"
# string_of_nat_option (minus zero five);;
- : string = "None"
# string_of_nat_option (minus zero zero);;
- : string = "0"

できたー!

多相的ヴァリアントとデータ構造とパターンマッチ

練習問題を解いたら結構長いコードになった。せっかくなので、記念カキコ。
作って満足してしまった。動作確認はまた今度。

(* 図形を定義 *)
type figure =
  Point
| Circle of float
| Rectangle of float * float
| Square of float;;

(* 座標情報をもったデータ *)
type 'a with_location = {loc_x : float; loc_y : float; body: 'a};;

type vector = Vector of float * float;;

(* 図形同士が重なっているかを判定*)
let rec overlap fig1 fig2 = 
  let (^-) p1 p2 = Vector (p1.loc_x -. p2.loc_x, p1.loc_y -. p2.loc_y) in
  let contains rect point =
    let Rectangle (w, h) = rect.body in
    let Vector (dx, dy) = point ^- rect in
    abs_float dx < w /. 2. && abs_float (dy) < h /. 2.
  in
  let dist p1 p2 = 
    let Vector (dx, dy) = p2 ^- p1 in
    sqrt (dx *. dx +. dy *. dy)
  in
  let get_nearest rect point =
    let Rectangle (w, h) = rect.body in
    let Vector (dx, dy) = point ^- rect in
    let w' = w /. 2. and h' = h /. 2. in
    {loc_x = if      dx >   w' then rect.loc_x +. w'
             else if dx < -.w' then rect.loc_x -. w'
             else point.loc_x;
     loc_y = if      dy >   h' then rect.loc_y +. h'
             else if dy < -.h' then rect.loc_y -. h'
             else point.loc_y;
     body = Point}
  in
  match (fig1.body, fig2.body) with
    (_, Square x) -> overlap fig1 {fig2 with body = Rectangle (x, x)}
  | (Point, Point) -> fig1.loc_x = fig2.loc_x && fig1.loc_y = fig2.loc_y
  | (Point, Circle r) -> dist fig1 fig2 < r
  | (Point, Rectangle _) -> contains fig2 fig1
  | (Circle r1, Circle r2) -> dist fig1 fig2 <= r1 +. r2
  | (Circle r, Rectangle _) -> dist (get_nearest fig2 fig1) fig1 < r
  | (Rectangle _, Rectangle _) -> contains (get_nearest fig2 fig1) fig1
  | (_, _) -> overlap fig2 fig1;;

しっかしこれ、型推論無しでやったら大変そうだなぁ。型推論超便利!

引き続きOCaml

自然数rについて、x*x + y * y = rを満たす自然数(x, y)のリストを返す関数
ただし、x ≧ y ≧ 0

# let squares r = 
    let isqrt n = int_of_float (sqrt (float_of_int n)) in
    let y_max = isqrt (r / 2) in
    let rec get_list y list = 
      if y >= y_max then list
      else 
        let x = isqrt (r - y * y) in
        if x * x + y * y = r
          then (x, y) :: get_list (y+1) list
          else get_list (y+1) list
    in get_list 0 [];;

実行例

# squares 36;;
- : (int * int) list = [(6, 0)]
# squares 1024;;
- : (int * int) list = [(32, 0)]
# squares 48612265;;
- : (int * int) list =
[(6972, 59); (6971, 132); (6952, 531); (6948, 581); (6944, 627); (6917, 876);
 (6899, 1008); (6853, 1284); (6789, 1588); (6772, 1659); (6756, 1723);
 (6651, 2092); (6637, 2136); (6576, 2317); (6556, 2373); (6413, 2736);
 (6404, 2757); (6384, 2803); (6259, 3072); (6213, 3164); (6124, 3333);
 (6048, 3469); (5907, 3704); (5832, 3821); (5691, 4028); (5656, 4077);
 (5613, 4136); (5432, 4371); (5243, 4596); (5179, 4668); (5139, 4712);
 (5008, 4851)]

KコンビネータとSコンビネータ

OCaml勉強中。KコンビネータとSコンビネータが出てきた。

OCamlでfun式と関数適用の組み合わせ「のみ」で表現できる関数はSとKのを関数適用で組み合わせることですべて表現できることが知られています。

# let s x y z = x z (y z);;
val s : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c = <fun>
# let k x y = x;;
val k : 'a -> 'b -> 'a = <fun>

で、s k k が恒等関数になると。

# s k k;; s k k;;
- : '_a -> '_a = <fun>

以下、いろいろ試してみた。

# k (s k k);;
- : '_a -> '_b -> '_b = <fun>
# k (k (s k k));;
- : '_a -> '_b -> '_c -> '_c = <fun>
# k (k (k (s k k)));;
- : '_a -> '_b -> '_c -> '_d -> '_d = <fun>
# k (k (k (k (s k k))));;
- : '_a -> '_b -> '_c -> '_d -> '_e -> '_e = <fun>

fun x y z -> xをやろうとしたけど、出来なかった。どうするんだろう。