-日時 :2006/6/26 (Mon) -場所 :名大 理学部1号館(多元数理科学研究科) 307室 -時刻 :18:00〜19:30 -参加者:??名 - コメントスパム削除しておきました -- &new{2007-02-16 (金) 19:04:40}; //#comment *Chapter 6. Exercise続き [#t10e4420] **Exercise 1 (吉岡)[#x1f19ca3] 時間がないので途中です。円形が正方形又は長方形と重なっている場合を検出できません。 type figure=Point|Circle of int|Rectangle of int*int|Square of int;; type loc_fig={x:int;y:int;fig:figure};; loc_figのx、yは図形の中心座標とします。 let square x = x*x;; let check x y z =if square(x)<=square(z) && square(y)<=square(z) then true else false;; let check2 x y =if square(x)<=square(y) then true else false;; let rec overlap a b= match (a.fig,b.fig) with (Circle r1,Circle r2)->if (square(a.x-b.x)+square(a.y-b.y))<=square(r1+r2)then true else false |(Square r1,Square r2)->check(a.x-b.x) (a.y-b.y) ((r1+r2)/2) |(Rectangle (rx1,ry1),Rectangle (rx2,ry2))->(check2 (a.x-b.x) ((rx1+rx2)/2)) && (check2 (a.y-b.y) ((ry1+ry2)/2)) |(Square r1,Rectangle (rx2,ry2))->check (a.x-b.x) (a.y-b.y) ((r1+rx2)/2) |(Rectangle (rx2,ry2),Square r1)->overlap(b,a); |_->false;; **Exercise 6 (小笠原) [#x9271744] **Exercise 7 (けいご) [#vde22fdd] type arith = Const of int | Add of arith * arith | Mul of arith * arith;; (* e1 は Const または Mul *) let rec mul' e1 e2 = match e2 with Add (e21,e22) -> Add (mul' e1 e21, mul' e1 e22) | Mul (e21,e22) -> Mul (e1, Mul (e21,e22)) | Const i -> Mul (e1, Const i) ;; let rec mul e1 e2 = match e1 with Const i -> mul' (Const i) e2 | Mul (e11,e12) -> mul' (Mul (e11, e12)) e2 | Add (e11,e12) -> Add (mul e11 e2, mul e12 e2);; let rec expand = function Const i -> Const i | Add (e1,e2) -> Add (expand e1,expand e2) | Mul (e1,e2) -> mul (expand e1) (expand e2);; let rec string_of_arith = function Const i -> string_of_int i | Add (e1,e2) -> "(" ^ string_of_arith e1 ^ "+" ^ string_of_arith e2 ^ ")" | Mul (e1,e2) -> "(" ^ string_of_arith e1 ^ "*" ^ string_of_arith e2 ^ ")" ;; **Exercise 8 (樋口)[#k7994cd4] 1,2,3,4からなる二分探索木を列挙し,それらを構成するためにaddに渡す要素の列を求めよ.~ まず,テキストより,2分木および,add, mem, preorderの定義があるとする. type 'a tree = Lf | Br of 'a * 'a tree * 'a tree let rec mem t x = match t with Lf -> false |Br (y,left,right) -> if x = y then true else if x < y then mem left x else mem right x let rec add t x = match t with Lf -> Br (x,Lf,Lf) |(Br (y,left,right) as whole) -> if x = y then whole else if x < y then Br(y, add left x, right) else Br(y, left, add right x) let rec preorder t l = match t with Lf -> l |Br(x, left, right) -> x :: (preorder left (preorder right l));; 基本方針は,[1;2;3;4]から順列を作り出し, それらをaddして得られたtreeをpreorderでめぐり, preorderがユニークなら新たな形の木として残し, addへの入力した列を保存してゆく. : makeUniqTreeInputs | excerciseの目標 [1;2;3;4] -> [(addへの入力のリスト)] : makeUniqTrees | makeUniqTreeInputs と同様だが,返すものがaddへ入力後のtreeのリストを得る. : makeSTree | 与えられたリストの要素を順にaddしtreeを得る. : permutation | リストから順列を得る : prefix | permutationで利用. ex. prefix [2;3] -> [[]; [2]; [2;3]] : suffix | permutationで利用. ex. suffix [2;3] -> [[2;3]; [3]; []] : interleave | permutationで利用. ex. interleave 1 [2;3] -> [[1;2;3]; [2;1;3]; [2;3;1]] let rec prefix = function [] -> [[]] |x::xs -> [] :: (List.map (fun el -> x::el) (prefix xs)) let rec suffix = function [] -> [[]] |x::xs -> (x::xs)::(suffix xs) let interleave el l = let pl = (prefix l) and sl = (suffix l) in (List.map2 (fun a b -> a @ el :: b) pl sl) let rec permutation = function [] -> [[]] |x::xs -> List.flatten (List.map (fun e -> (interleave x e)) (permutation xs)) let rec makeSTree = function [] -> Lf |x::xs -> add (makeSTree xs) x let makeUniqTreeInputs nodes = let addTree input set = let pord = (preorder (makeSTree input) []) in if List.mem pord (fst set) then set else ((pord::(fst set)),input::(snd set)) in let rec addTrees nodel set = match nodel with [] -> (set) |x::xs -> addTree x (addTrees xs set) in snd (addTrees (permutation nodes) ([],[])) let makeUniqTrees nodes = let rec input2trees = function []->[]|x::xs -> (makeSTree x)::(input2trees xs) in input2trees (makeUniqTreeInputs nodes);; ***実行結果 [#k19a8025] # makeUniqTreeInputs [1;2;3;4];; - : int list list = [[1; 2; 3; 4]; [2; 1; 3; 4]; [2; 3; 1; 4]; [2; 3; 4; 1]; [3; 1; 2; 4]; [3; 2; 1; 4]; [3; 2; 4; 1]; [3; 4; 1; 2]; [3; 4; 2; 1]; [4; 1; 2; 3]; [4; 2; 1; 3]; [4; 2; 3; 1]; [4; 3; 1; 2]; [4; 3; 2; 1]] # makeUniqTrees [1;2;3;4];; - : int tree list = [Br (4, Br (3, Br (2, Br (1, Lf, Lf), Lf), Lf), Lf); Br (4, Br (3, Br (1, Lf, Br (2, Lf, Lf)), Lf), Lf); Br (4, Br (1, Lf, Br (3, Br (2, Lf, Lf), Lf)), Lf); Br (1, Lf, Br (4, Br (3, Br (2, Lf, Lf), Lf), Lf)); Br (4, Br (2, Br (1, Lf, Lf), Br (3, Lf, Lf)), Lf); Br (4, Br (1, Lf, Br (2, Lf, Br (3, Lf, Lf))), Lf); Br (1, Lf, Br (4, Br (2, Lf, Br (3, Lf, Lf)), Lf)); Br (2, Br (1, Lf, Lf), Br (4, Br (3, Lf, Lf), Lf)); Br (1, Lf, Br (2, Lf, Br (4, Br (3, Lf, Lf), Lf))); Br (3, Br (2, Br (1, Lf, Lf), Lf), Br (4, Lf, Lf)); Br (3, Br (1, Lf, Br (2, Lf, Lf)), Br (4, Lf, Lf)); Br (1, Lf, Br (3, Br (2, Lf, Lf), Br (4, Lf, Lf))); Br (2, Br (1, Lf, Lf), Br (3, Lf, Br (4, Lf, Lf))); Br (1, Lf, Br (2, Lf, Br (3, Lf, Br (4, Lf, Lf))))] ***おまけ [#m4ad1608] let trees2dot inputs = let rec trees2edges inputs delta= let rec tree2edges n = function Lf -> "L" ^ (string_of_int n) |Br(x,left,right) -> (string_of_int (x+n))^"[label="^(string_of_int x)^"];"^ match (left,right)with (Lf,Lf) -> "" |(Br(x1,_,_),Br(x2,_,_)) -> (string_of_int (x+n))^":sw ->"^(string_of_int (x1+n))^";" ^(string_of_int (x+n))^":se ->"^(string_of_int (x2+n))^";" ^(tree2edges n left) ^(tree2edges n right) |(Br(x1,_,_),Lf) -> (string_of_int (x+n))^":sw ->"^(string_of_int (x1+n))^";" ^(tree2edges n left) |(Lf,Br(x2,_,_)) -> (string_of_int (x+n))^":se ->"^(string_of_int (x2+n))^";" ^(tree2edges n right) in match inputs with [] -> "" |x::xs -> (tree2edges delta (makeSTree x) ) ^ " " ^ (trees2edges xs (delta+(List.length x))) in "digraph forrest{ node [shape=box];"^(trees2edges inputs 0)^"}";; trees2dot (makeUniqTreeInputs [1;2;3;4]);; #ref(test.png) **Exercise 9 (源馬) [#s4d9ace6] 無限リストを使って1000番目(あるいは学籍番号+3000)の素数を求める。 type 'a seq = Cons of 'a * (unit -> 'a seq);; let rec from n = Cons (n, fun () -> from (n + 1));; let head (Cons (x, _)) = x;; let tail (Cons (_, f)) = f ();; let rec take n s = if n = 0 then [] else head s :: take (n - 1) (tail s);; let rec sift n f = if (head f) mod n = 0 then sift n (tail f) else Cons (head f, fun () -> sift n (tail f));; let rec sieve (Cons (x, f)) = Cons (x, fun () -> sieve (sift x (f())));; let primes = sieve (from 2);; take 20 primes;; let rec nthseq n (Cons (x, f)) = if n = 1 then x else nthseq (n - 1) (f());; nthseq 1000 primes;; 解説。~ sieveの定義を見る。~ sift n f は、Cons (整数, thunk) を返すようだ。~ sieve (from 2)を見る。~ sieve (from 2)を人間評価して見る。sieve (Cons (2, from 3)) = Cons (2, fun () -> sieve (sift 2 (from 3)));;~ さあ、 sift 2 (from 3)) が登場した。~ ちなみに、素数列は、Cons (2, Cons (3, Cons (5, ...) だ。~ sieve (from 2)を実行した結果がそうなることを期待するのだから、経過として、~ Cons (2, fun () -> sieve (sift 2 (from 3))) Cons (2, Cons (3, fun () -> sieve (sift 3 (sift 2 (from 4))))) Cons (2, Cons (3, fun () -> sieve (sift 3 (sift 2 (from 5))))) Cons (2, Cons (3, Cons (5, fun () -> sieve (sift 5 (sift 3 (sift 2 (from 6))))))) Cons (2, Cons (3, Cons (5, fun () -> sieve (sift 5 (sift 3 (sift 2 (from 7))))))) Cons (2, Cons (3, Cons (5, Cons (7, fun () -> sieve (sift 7 (sift 5 (sift 3 (sift 2 (from 8))))))))) だろう。~ リスト風で書けば、~ 2, fun () -> sieve (sift 2 (from 3)) 2, 3, fun () -> sieve (sift 3 (sift 2 (from 4))) 2, 3, fun () -> sieve (sift 3 (sift 2 (from 5))) 2, 3, 5, fun () -> sieve (sift 5 (sift 3 (sift 2 (from 6)))) 2, 3, 5, fun () -> sieve (sift 5 (sift 3 (sift 2 (from 7)))) 2, 3, 5, 7, fun () -> sieve (sift 7 (sift 5 (sift 3 (sift 2 (from 8))))) となる。~ よく見てほしい。~ sift 2 (from 3)は、 Cons (3, fun () -> sift 2 (from 4)) を返すのだということがわかるまで。~ そして、次の行。~ sift 2 (from 4)は、4が2で割り切れることに気づき、ただちに次の数字をよこせと、(from 4)に要求する。それで、(from 5)をもらえて一安心。~ sift 2 (from 5)は、Cons (5, fun () -> sift 2 (from 6)) を返す。~ それを受け取った sift 3 Cons (5, fun () -> sift 2 (from 6)) は、5が3で割り切れないことに安心しつつ、Cons (5, fun () -> sift 3 (sift 2 (from 6)))を返す。~ sift n fの定義は、~ head fを見て、割り切れることに気づいたら、ただちにtail fでやり直す。~ 割り切れなかったら、安心しつつ、Cons (head f, fun () -> sift n (tail f)) を返す。~ let rec sift n f = if (head f) mod n = 0 then sift n (tail f) else Cons (head f, fun () -> sift n (tail f));; *Chapter 7. Exercise [#dc67177c] **Exercise 1 [#oe649801] ref型を type 'a ref = { mutable contents : 'a};; こんな定義の更新可能レコードと見て, 関数ref, 前置演算子!, 中置演算子:= をレコード操作で書け. -関数ref # let ref x = { contents = x } ;; val ref : 'a -> 'a ref = <fun> -前置演算子! # let ( ! ) x = x.contents ;; val ( ! ) : 'a ref -> 'a = <fun> -中置演算子:= # let ( := ) x y = x.contents <- y;; val ( := ) : 'a ref -> 'a -> unit = <fun> **Exercise 2 [#u76c0a17] 整数の参照をインクリメントする関数incr # let incr x = x := !x + 1;; val incr : int ref -> unit = <fun> **Exercise 3 [#fe92b783] # let f = ref (fun y -> y+1) let funny_fact x = if x = 1 then 1 else x * (!f(x-1));; # f := funny_fact;; # funny_fact 5;; let fは単に関数の参照が用意したいだけで,funで定義された関数の中身に意味は無い.(例えば let f = ref (fun y -> 1) でもOK)~ f := funny_factによりfがfunny_factをさすようになる.~ その結果,funny_factの定義中の!fが自分自身(funny_fact)を呼ぶ事になり,~ 階乗を素直に再帰的に定義した時と同じ形になっている. **Exercise 4 [#v6d2c968] # let fact_imp n = let i = ref n and res = ref 1 in while ( !i > 0 ) do res := !res * !i; i := !i - 1 done; !res;; val fact_imp : int -> int = <fun> **Exercise 5(みずの) [#q5984fe9] let rec fact n = if n < 0 then raise (Invalid_argument "n should be positive") else if n = 0 then 1 else n*fact(n-1);; **Exercise 6 (飯田)[#ke8a0983] 先週お話があった、値多相についての問題。 letで名前が与えられる式の右辺が値であるときのみ、その変数が多相的に使える。 1 # let x = ref [];; val x : '_a list ref = {contents = []} '_a listは一度だけ任意の型に置換できる型変数である。 こうすることで、 # x := [1];; # true :: !x;; が許されてしまうのを防いでいる。xの型は[1]を代入したときに int list ref となる。 # true :: !x;; Characters 8-10: true :: !x;; ^^ This expression has type int list but is here used with type bool list 2 getとsetの定義。 # let (get, set) = let r = ref [] in ((fun () -> !r), (fun x -> r := x));; val get : unit -> '_a list = <fun> val set : '_a list -> unit = <fun> getは !r 返す関数なので、unit -> '_a list setは rにxを格納する関数なので、'_a list -> unit 次に、 # 1 :: get ();; - : int list = [1] この時点で参照 r の型が int list ref に置換されるので、 get : unit -> int list set : int list -> unit となる。 # 1.0 :: get();; Characters 7-12: 1.0 :: get();; ^^^^^ This expression has type int list but is here used with type float list **Exercise 7 (吉岡)[#n2c3331e] 元のプログラムだと、pointCのincを継承した時に、 setが処理されcol:=WhileのあるcpointC内のcsetが実行されていない。 そのため、cincをしても座標はセットされるが、白色がセットされない。 そこで、pointCで継承するメソッドをsetからcsetにcpointCで変更できるようにする。 type pointI={get:unit->int;set:int->unit;inc:unit->unit};; let pointC x this () ={ get=(fun () -> !x); set=(fun newx -> x:=newx); inc=(fun () -> (this ()).set ((this ()).get () + 1)) };; let new_point x = let x = ref x in let rec this () = pointC x this () in this ();; 相互再帰でsuper ()とthis ()を定義している。 super ()、this ()となっているのは、相互再帰が関数でのみ定義できるから。 type color=Blue|Red|Green|White;; type cpointI={cget:unit->int;cset:int->unit;cinc:unit->unit;getcolor:unit->color};; let cpointC x col= let rec super ()= pointC x (fun ()->{get=(this ()).cget;set=(this ()).cset;inc=(this ()).cinc}) () and this ()= {cget= (super ()).get; cset= (fun x -> (super ()).set x; col := White); cinc= (super ()).inc; getcolor = (fun () -> !col)} in this ();; let new_cpoint x col = cpointC (ref x) (ref col);; 実行結果: # cp.cinc();; - : unit = () # cp.cget();; - : int = 1 # cp.getcolor();; - : color = White **Exercise 8 (末次) [#n6faefa9] まず元の定義 let rec change = function (_, 0) -> [] | ((c :: rest) as coins, total) -> if c > total then change (rest, total) else c :: change (coins, total - c) ;; これだと let us_coins = [25; 10; 5; 1] and gb_coins = [50; 20; 10; 5; 2; 1];; change (gb_coins, 43);; change (us_coins, 43);; は成功するが、 change ([5; 2], 16);; Exception: Match_failure ("", 66, -211). となって失敗する.これは大きい額から試していくので 5 で3回割ったあと、リストの最後 nil まで行って、 ([], 1) にマッチする規則が無いため. そこで失敗したら戻って小さな額で割るようにすればよい. let rec change = function (_, 0) -> [] | ((c :: rest) as coins, total) -> if c > total then change (rest, total) else (try c :: change (coins, total - c) with Failure "change" -> change (rest, total)) (* 失敗したら c で割るのを諦めて次に小さい数で続ける *) | _ -> raise (Failure "change");; (* ([], 1以上) のときは例外を投げる *) このようにすれば change ([5; 2], 16);; - : int list = [5; 5; 2; 2; 2] と計算できる. **Exercise 9 (下村) [#l136f82b] すいません、時間がなくてあんまり考えてません…。 こんなんでいいのだろうか。簡単すぎ? let print_int x = output_string stdout (string_of_int x);; **Exercise 10(山畑) [#l213c9f8] ファイルをコピーする関数cpを書く let cp infn outfn = let input = open_in infn in let output = open_out outfn in try while true do output_string output ((input_line input) ^ "?n") done with End_of_file -> (); close_in input; close_out output;; 自分で改行を入れるのはどうかと思う。