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

```# 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 -> 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構築まで~

```# 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)))))
```

とんでもないことになったｗ

```# 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 = 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
```

このとき、解無しを返すようにしてみます。そのために、まずはオプション型を定義して、引き算の関数を書き換えます。

```# 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

ただし、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をやろうとしたけど、出来なかった。どうするんだろう。