├── .gitignore ├── DFT ├── .ocamlinit ├── OMakefile ├── README ├── main.ml └── test.ml ├── OMakefile ├── OMakeroot ├── README ├── algebra ├── .ocamlinit ├── OMakefile └── main.ml ├── clustering ├── .ocamlinit ├── OMakefile ├── main.ml ├── main.mli └── test.ml ├── differentialEquation ├── .ocamlinit ├── OMakefile ├── README ├── euler.ml ├── symplecticEuler.ml └── test.ml ├── dijkstra ├── .ocamlinit ├── OMakefile ├── main.ml └── test.ml ├── eratosthenes ├── .ocamlinit ├── OMakefile ├── README ├── main.ml └── test.ml ├── ford-fulkerson ├── .ocamlinit ├── OMakefile ├── main.ml └── test.ml ├── geometry ├── .ocamlinit ├── OMakefile ├── README ├── main.ml └── test.ml ├── graph ├── .ocamlinit ├── OMakefile ├── README ├── draw.ml ├── graph.ml └── test.ml ├── knapsack ├── .ocamlinit ├── OMakefile ├── README ├── main.ml ├── main.mli └── test.ml ├── kruskal ├── .ocamlinit ├── OMakefile ├── main.ml └── test.ml ├── machineLearning ├── .ocamlinit ├── OMakefile ├── README └── sequentialPrediction.ml ├── matrix ├── .ocamlinit ├── OMakefile ├── README ├── main.ml └── test.ml ├── polynomialRing ├── .ocamlinit ├── OMakefile ├── polynomialRing.ml └── polynomialRing_test.ml ├── rational ├── .ocamlinit ├── OMakefile ├── README ├── rational.ml ├── rational.mli ├── rationalBig.ml ├── rationalBig.mli └── rational_test.ml ├── sort ├── .ocamlinit ├── OMakefile ├── main.ml └── test.ml ├── string ├── .ocamlinit ├── OMakefile ├── fpiSummerIntern2011Quiz.ml ├── suffixArray.ml ├── suffixArray.mli └── test.ml ├── timer_test ├── .ocamlinit ├── OMakefile ├── README └── main.ml ├── tree ├── .ocamlinit ├── OMakefile ├── redBlackTree.ml ├── splayTree.ml └── test.ml └── util ├── .ocamlinit ├── OMakefile ├── test.ml ├── util.ml ├── utilArray.ml ├── utilArray.mli ├── utilList.ml ├── utilList.mli ├── utilPervasives.ml └── utilPervasives.mli /.gitignore: -------------------------------------------------------------------------------- 1 | graph/Ubigraph.ml 2 | graph/ubigraphtop 3 | *.omc 4 | *.run 5 | *.opt 6 | *.annot 7 | *.cm[ioa] 8 | *.log 9 | *.o 10 | *.a 11 | *.cmx 12 | *.cmxa 13 | *.out 14 | *.cmt 15 | *.cmti 16 | *.omakedb 17 | *.omakedb.lock 18 | util/META 19 | util/install 20 | *~ 21 | #*# 22 | -------------------------------------------------------------------------------- /DFT/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /DFT/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | 8 | OCamlProgram($(PROGRAM), $(FILES)) 9 | 10 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 11 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 12 | 13 | .PHONY: clean 14 | clean: 15 | rm -f \ 16 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 17 | $(PROGRAM).run $(PROGRAM).opt 18 | -------------------------------------------------------------------------------- /DFT/README: -------------------------------------------------------------------------------- 1 | ・Cooley-Tukey型FFTアルゴリズム.計算量O(NlogN).ただし2の巾乗でない長さの入力に対しては0を詰めるもっとも単純な実装になっているので無駄が生じる. 2 | ・せっかくなので複素数環以外にも適用できるようにした. 3 | ・どうせ使わないのでいいのだが,設計上,浮動小数点演算が含まれる場合には離散フーリエ係数テーブル生成時に大きな誤差が乗るので注意. -------------------------------------------------------------------------------- /DFT/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type Ring = sig 4 | type t 5 | val zero : t 6 | val one : t 7 | val ( +^ ) : t -> t -> t 8 | val ( *^ ) : t -> t -> t 9 | val ( =^ ) : t -> t -> bool 10 | end 11 | 12 | module Make (R : Ring) : sig 13 | type elt = R.t 14 | type t = elt array 15 | val dft : elt -> t -> t 16 | end = 17 | struct 18 | type elt = R.t 19 | type t = elt array 20 | 21 | let ( +^ ) = R.( +^ ) 22 | let ( *^ ) = R.( *^ ) 23 | let ( =^ ) = R.( =^ ) 24 | 25 | let bitrev m i = 26 | let rec bitrev_aux accum i = function 27 | 0 -> accum 28 | | j -> bitrev_aux (1 land i :: accum) (i lsr 1) (j - 1) 29 | and to_int accum d = function 30 | [] -> accum 31 | | hd :: tl -> to_int (hd * d + accum) (d * 2) tl 32 | in 33 | bitrev_aux [] i m |> to_int 0 1 34 | 35 | let dft w xs = 36 | let n = Array.length xs in 37 | let m = minimum_bigger_power_of_two n in 38 | let n' = int_exp 2 m in 39 | let ws = Array.init n (general_exp R.one ( *^ ) w) 40 | and pair step i = 41 | let span = int_exp 2 step in 42 | let is_even = i / span mod 2 = 0 in 43 | (is_even, i + if is_even then span else (-span)) 44 | in 45 | let rec dft_aux xs step = 46 | if step = m then xs 47 | else 48 | let butterfly i x = 49 | let (is_even, j) = pair step i 50 | and pow = int_exp 2 (m - step - 1) * i mod n in 51 | if is_even then x +^ xs.(j) *^ ws.(pow) 52 | else xs.(j) +^ x *^ ws.(pow) 53 | in 54 | dft_aux (Array.mapi butterfly xs) (step + 1) 55 | in 56 | dft_aux (Array.init n' (fun i -> try xs.(bitrev m i) with Invalid_argument _ -> R.zero)) 0 57 | end 58 | -------------------------------------------------------------------------------- /DFT/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Main 3 | 4 | (* symbol *) 5 | module String = struct 6 | type t = V of string | P of t * t | M of t * t | E of t * int 7 | let zero = V "0" 8 | let one = V "1" 9 | let ( +^ ) x y = match (x, y) with 10 | (V "0", x) | (x, V "0") -> x 11 | | _ -> P (x, y) 12 | let ( *^ ) x y = match (x, y) with 13 | (V "0", x) | (x, V "0") -> zero 14 | | (V "1", y) -> y 15 | | (x, V "1") -> x 16 | | (V a, V b) when a = b -> E (V a, 2) 17 | | (E (V a, n), E (V b, m)) when a = b -> E (V a, m + n) 18 | | (E (V a, n), V b) | (V b, E (V a, n)) when a = b -> E (V a, n + 1) 19 | | (_, _) -> M (x, y) 20 | let ( =^ ) = (=) 21 | let rec to_string = function 22 | V s -> s 23 | | P (a, b) -> "(" ^ to_string a ^ " + " ^ to_string b ^ ")" 24 | | M (a, b) -> to_string a ^ " * " ^ to_string b 25 | | E (a, n) -> to_string a ^ "^" ^ string_of_int n 26 | end 27 | 28 | module DFT = Make (String) 29 | 30 | open String 31 | 32 | let x = DFT.dft (V "x") [|V "a";V "b";V "c";V "d"|] |> Array.map to_string 33 | let y = DFT.dft (V "y") [|V "a";V "b";V "c";V "d";V "e";V "f";V "g"|] |> Array.map to_string 34 | let z = DFT.dft (V "z") [|V "a";V "b";V "c";V "d";V "e";V "f";V "g";V "h"|] |> Array.map to_string 35 | 36 | 37 | (* complex number *) 38 | module Complex = struct 39 | type t = float * float 40 | let zero = (0., 0.) 41 | let one = (1., 0.) 42 | let ( +^ ) (xr, xi) (yr, yi) = (xr +. yr, xi +. yi) 43 | let ( *^ ) (xr, xi) (yr, yi) = (xr *. yr -. xi *. yi, xr *. yi +. yr *. xi) 44 | let ( =^ ) x y = x = y 45 | end 46 | 47 | module DFT2 = Make (Complex) 48 | 49 | open Complex 50 | 51 | let pi = atan 1. *. 4. 52 | let rect n m = Array.init (2 * n) (fun i -> if n - m <= i && i < n + m then one else zero) 53 | let kernel n = 54 | let theta = -1. *. pi /. float n in 55 | (cos theta, sin theta) 56 | let sinc n m = DFT2.dft (kernel n) (rect n m) 57 | -------------------------------------------------------------------------------- /OMakefile: -------------------------------------------------------------------------------- 1 | NATIVE_ENABLED = false 2 | BYTE_ENABLED = true 3 | 4 | USE_OCAMLFIND = true 5 | OCAMLFLAGS += 6 | OCAMLCFLAGS = -dtypes -g -w ys 7 | OCAMLFINDFLAGS += 8 | 9 | OCAMLINCLUDES += ../util 10 | OCAML_LIBS[] = ../util/util 11 | 12 | .SUBDIRS:string clustering algebra differentialEquation machineLearning polynomialRing matrix rational geometry timer_test dijkstra DFT tree ford-fulkerson kruskal eratosthenes knapsack sort util graph -------------------------------------------------------------------------------- /OMakeroot: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # Permission is hereby granted, free of charge, to any person 3 | # obtaining a copy of this file, to deal in the File without 4 | # restriction, including without limitation the rights to use, 5 | # copy, modify, merge, publish, distribute, sublicense, and/or 6 | # sell copies of the File, and to permit persons to whom the 7 | # File is furnished to do so, subject to the following condition: 8 | # 9 | # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 10 | # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 11 | # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 12 | # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 13 | # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 14 | # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR 15 | # THE USE OR OTHER DEALINGS IN THE FILE. 16 | 17 | ######################################################################## 18 | # The standard OMakeroot file. 19 | # You will not normally need to modify this file. 20 | # By default, your changes should be placed in the 21 | # OMakefile in this directory. 22 | # 23 | # If you decide to modify this file, note that it uses exactly 24 | # the same syntax as the OMakefile. 25 | # 26 | 27 | # 28 | # Include the standard installed configuration files. 29 | # Any of these can be deleted if you are not using them, 30 | # but you probably want to keep the Common file. 31 | # 32 | open build/C 33 | open build/OCaml 34 | open build/LaTeX 35 | 36 | # 37 | # The command-line variables are defined *after* the 38 | # standard configuration has been loaded. 39 | # 40 | DefineCommandVars() 41 | 42 | # 43 | # Include the OMakefile in this directory. 44 | # 45 | .SUBDIRS: . 46 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 各種アルゴリズムをOCamlで実装しています. 2 | 3 | Required(in graph related modules) : xmlrpc-light, UbiGraph and everything they require. 4 | 5 | 参考文献: 6 | [1] George T. Heineman, Gary Pollice, Stanley Selkow 著. 黒川 利明, 黒川 洋 訳. アルゴリズムクイックリファレンス. O'Reilly Japan, 2010. 7 | [2] Okasaki, C. Simple and Efficient Purely Functional Queues and Deques. J. Functional Programming, 5(4), 583–592, 1995. 8 | [3] D.Cox, J.Little, D.O'Shea. Ideals, Varieties, and Algorithms -- An Introduction to Commutative Algebraic Geometry and Commutative Algebra. Springer-Verlag, 1991. 9 | [4] 野呂 正行, 横山 和弘. グレブナー基底の計算 基礎篇 計算代数入門. 東京大学出版会, 2003. 10 | [5] B.Korte, J.Vygen 著. 浅野 孝夫, 浅野 泰仁, 小野 孝男, 平田 富夫 訳. 組合せ最適化-理論とアルゴリズム 第二版. シュプリンガージャパン, 2009. 11 | [6] 杉原正顯, 室田一雄. 岩波数学叢書 線形計算の数理. 岩波書店, 2009. 12 | -------------------------------------------------------------------------------- /algebra/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util" 2 | #load "util.cma" 3 | #use "main.ml" 4 | -------------------------------------------------------------------------------- /algebra/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | 6 | OCamlProgram($(PROGRAM), $(FILES)) 7 | 8 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 9 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 10 | 11 | .PHONY: clean 12 | clean: 13 | rm -f \ 14 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 15 | $(PROGRAM).run $(PROGRAM).opt 16 | -------------------------------------------------------------------------------- /algebra/main.ml: -------------------------------------------------------------------------------- 1 | (* type si = {s : int; m : int} 2 | let x : si = {s = 0; m = 1} 3 | let t : si = {s = 1; m = 0} 4 | *) 5 | 6 | open Util 7 | 8 | type symbol = 9 | ConstSymbol of float 10 | | Func of string list (* constructor is a list of arguments *) 11 | | Var 12 | 13 | type env = (string * symbol) list 14 | 15 | let env : env = [("x", Var); ("t", Var); ("u", Func ["x";"t"])] 16 | 17 | type dvar = string * ((string * int) list) 18 | (* snd represents how many times differentiated by what variable *) 19 | 20 | type expr = 21 | Const of int (* todo : change to rational *) 22 | | DVar of dvar 23 | | Sum of expr * expr 24 | | Prod of expr * expr 25 | | Partial of string * expr 26 | | Power of expr * int 27 | 28 | let t1 = DVar ("u", ["t", 1]) 29 | let t2 = Prod ((DVar ("u", [])), (DVar ("u", ["x", 1]))) 30 | let t3 = DVar ("u", ["x", 3]) 31 | let kdv = Sum (t1, Sum(t2, t3)) 32 | 33 | let expr1 a b = Prod (Power (DVar ("u", []), a), Power((DVar ("u", ["x", 1])), b)) 34 | 35 | let string_of_diff_args xs = 36 | let concat = String.concat "" in 37 | List.map (fun (s, i) -> concat (List.init (fun _ -> s) i)) xs |> concat 38 | 39 | let rec partial env s expr = 40 | let rec aux expr = 41 | match expr with 42 | Const i -> Const 0 43 | | DVar (v, xs) -> begin 44 | match List.assoc v env with 45 | ConstSymbol _ -> Const 0 46 | | Var -> if s = v then Const 1 else Const 0 47 | | Func args -> 48 | if List.exists ((=) s) args then 49 | try 50 | let order = List.assoc s xs in 51 | let xs = (s, order + 1) :: List.remove (fun x -> fst x = s) xs in 52 | DVar (v, xs) 53 | with 54 | Not_found -> DVar (v, (s, 1) :: xs) 55 | else 56 | Const 0 end 57 | | Sum (l, r) -> Sum (aux l, aux r) 58 | | Prod (l, r) -> Sum (Prod (aux l, r), Prod (l, aux r)) 59 | | Partial (s', e) -> aux (partial env s' e) 60 | | Power (e, i) -> 61 | if i < 0 then failwith "negative power not allowed." 62 | else if i = 0 then Const 0 63 | else if i = 1 then aux e 64 | else aux (Prod (e, Power (e, i - 1))) 65 | in 66 | (try 67 | if List.assoc s env <> Var then failwith "not variable" 68 | with 69 | Not_found -> failwith "not in env"); 70 | aux expr 71 | 72 | let print_expr expr = 73 | let open_paren prec op_prec = 74 | if prec > op_prec then print_string "(" 75 | and close_paren prec op_prec = 76 | if prec > op_prec then print_string ")" 77 | in 78 | let rec print prec = function 79 | Const i -> print_int i 80 | | DVar (s, xs) -> begin 81 | match xs with 82 | [] -> print_string s 83 | | xs -> print_string (s ^ "_" ^ string_of_diff_args xs) end 84 | | Sum (l, r) -> 85 | open_paren prec 0; 86 | print 0 l; print_string " + "; print 0 r; 87 | close_paren prec 0 88 | | Prod (l, r) -> 89 | open_paren prec 2; 90 | print 2 l; print_string " * "; print 2 r; 91 | close_paren prec 2 92 | | Partial (s, e) -> 93 | print_string ("d/d" ^ s); 94 | print 0 e; 95 | | Power (e, i) -> 96 | if i = 0 then () 97 | else if i = 1 then print 3 e 98 | else begin 99 | open_paren prec 3; 100 | print 3 e; 101 | close_paren prec 3; 102 | print_string ("^" ^ string_of_int i) 103 | end 104 | in 105 | print 0 expr; 106 | print_newline () 107 | -------------------------------------------------------------------------------- /clustering/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util" 2 | #load "util.cma" 3 | #load "main.cmo" 4 | #use "./test.ml" 5 | -------------------------------------------------------------------------------- /clustering/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCamlProgram($(PROGRAM), $(FILES)) 8 | 9 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 10 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 11 | 12 | .PHONY: clean 13 | clean: 14 | rm -f \ 15 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 16 | $(PROGRAM).run $(PROGRAM).opt 17 | -------------------------------------------------------------------------------- /clustering/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let kmeans 4 | dist 5 | make_centroid 6 | ?(initialize_centroids = Array.select_rand) 7 | ?(term_iter = 1000) 8 | ?(term_error = 10e-12) 9 | points 10 | n 11 | = 12 | let select_cluster centroids point = Array.find_min_num (dist point) centroids 13 | and filter_cluster clusters = 14 | let result = Array.make n [] in 15 | let _ = Array.iteri (fun j c -> result.(c) <- points.(j) :: result.(c)) clusters in 16 | result 17 | in 18 | let rec aux iter clusters old_centroids = 19 | let new_centroids = Array.map make_centroid (filter_cluster clusters) in 20 | let clusters = Array.map (select_cluster new_centroids) points in 21 | let error = Array.map2 dist new_centroids old_centroids |> Array.find_max identity in 22 | if error < term_error || iter > term_iter then clusters 23 | else aux (iter + 1) clusters new_centroids 24 | in 25 | let init_centroids = initialize_centroids n points in 26 | let init_clusters = Array.map (select_cluster init_centroids) points in 27 | aux 0 init_clusters init_centroids 28 | -------------------------------------------------------------------------------- /clustering/main.mli: -------------------------------------------------------------------------------- 1 | val kmeans : 2 | ('a -> 'a -> float) -> (* distance between two points *) 3 | ('a list -> 'a) -> (* centroid of points *) 4 | ?initialize_centroids:(int -> 'a array -> 'a array) -> (* select k initial centroids *) 5 | ?term_iter:int -> (* max iteration *) 6 | ?term_error:float -> (* terminates if the largest centroid movement in the update is smaller than this value *) 7 | 'a array -> (* points *) 8 | int -> (* #clusters *) 9 | int array 10 | -------------------------------------------------------------------------------- /clustering/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Main 3 | 4 | let dist (x1, y1) (x2, y2) = sqrt((x2 -. x1) ** 2. +. (y2 -. y1) ** 2.) 5 | let mc points = 6 | let (x, y) = List.fold_left (fun (x1, y1) (x2, y2) -> (x1 +. x2, y1 +. y2)) (0., 0.) points in 7 | let denom = List.length points |> float in 8 | (x /. denom, y /. denom) 9 | 10 | let random_point (c_x, c_y) sigma = 11 | let (rand_x, rand_y) = box_muller () in 12 | (c_x +. rand_x *. sigma, c_y +. rand_y *. sigma) 13 | 14 | let random_points n = 15 | let a = Array.append 16 | (Array.init (n / 4) (fun _ -> random_point (1., 1.) 0.1)) 17 | (Array.init (n / 4) (fun _ -> random_point (-1., -1.) 0.1)) 18 | and b = Array.append 19 | (Array.init (n / 4) (fun _ -> random_point (-1., 1.) 0.1)) 20 | (Array.init (n / 4) (fun _ -> random_point (1., -1.) 0.1)) 21 | in 22 | Array.append a b 23 | 24 | let points = random_points 100 25 | 26 | let clustering_result = Main.kmeans dist mc points 4 27 | -------------------------------------------------------------------------------- /differentialEquation/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/util.cma";; 3 | #load "./euler.cmo";; 4 | #load "./symplecticEuler.cmo";; 5 | #use "./test.ml";; 6 | -------------------------------------------------------------------------------- /differentialEquation/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | test 5 | euler 6 | symplecticEuler 7 | 8 | 9 | OCamlProgram($(PROGRAM), $(FILES)) 10 | 11 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 12 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 13 | 14 | .PHONY: clean 15 | clean: 16 | rm -f \ 17 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 18 | $(PROGRAM).run $(PROGRAM).opt 19 | -------------------------------------------------------------------------------- /differentialEquation/README: -------------------------------------------------------------------------------- 1 | ・SymplecticEuler : 1次のシンプレクティックオイラー法.ハミルトン系に適用する離散化スキームであり,修正されたハミルトニアンを保存する性質を持つ.このプログラムでは二重振り子を解いている.途中で出てくる非線形方程式はニュートン法で解いている(間違った局所解に落ちる可能性はあるが前ステップの値を初期値にとれば多分間違えないだろうという見込み). 2 | -------------------------------------------------------------------------------- /differentialEquation/euler.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let cos2 x = cos x ** 2. 4 | 5 | let to_general_coord (m1, m2) (l1, l2) (th1, th2, thd1, thd2) = 6 | let q1, q2 = th1, th2 7 | and a11 = (m1 +. m2) *. l1 ** 2. 8 | and a12 = m2 *. l1 *. l2 *. cos (th1 -. th2) 9 | and a22 = m2 *. l2 ** 2. 10 | in 11 | let p1 = a11 *. thd1 +. a12 *. thd2 12 | and p2 = a12 *. thd1 +. a22 *. thd2 13 | in 14 | (q1, q2, p1, p2) 15 | 16 | let of_general_coord (m1, m2) (l1, l2) (q1, q2, p1, p2) = 17 | let th1, th2 = q1, q2 in 18 | let thd = th1 -. th2 in 19 | let divider = (m2 *. l1 *. l2) ** 2. *. ((m1 +. m2) /. m2 -. cos2 thd) 20 | in 21 | let b11 = m2 *. l2 ** 2. /. divider 22 | and b12 = -1. *. m2 *. l1 *. l2 *. cos thd /. divider 23 | and b22 = (m1 +. m2) *. l1 ** 2. /. divider 24 | in 25 | let thd1 = b11 *. p1 +. b12 *. p2 26 | and thd2 = b12 *. p1 +. b22 *. p2 27 | in 28 | (th1, th2, thd1, thd2) 29 | 30 | let energy (m1, m2) (l1, l2) gravity (th1, th2, thd1, thd2) = 31 | let t = 0.5 *. m1 *. (l1 *. thd1) ** 2. +. 0.5 *. m2 *. ((l1 *. thd1) ** 2. +. (l2 *. thd2) ** 2. +. 2. *. l1 *. l2 *. thd1 *. thd2 *. cos (th1 -. th2)) 32 | and u = -1. *. m1 *. l1 *. gravity *. cos th1 -. m2 *. gravity *. (l1 *. cos l1 +. l2 *. cos l2) 33 | in 34 | t +. u 35 | 36 | let print out_ch m l gravity ((th1, th2, thd1, thd2) as x) = 37 | let energy = energy m l gravity x in 38 | Printf.fprintf out_ch "%f %f %f %f %f\n" th1 th2 thd1 thd2 energy 39 | 40 | let main turn (m1, m2) (l1, l2) gravity h (th1, th2, thd1, thd2) out_ch = 41 | Printf.fprintf out_ch "# euler method. weight : (%f, %f) length : (%f, %f) gravity : %f stepsize : %f num_step : %d init : (%f, %f, %f, %f)\n" m1 m2 l1 l2 gravity h turn th1 th2 thd1 thd2; 42 | (* calculate sub constants *) 43 | let m = m2 /. (m1 +. m2) 44 | and l = l2 /. l1 45 | and omega_squared = gravity /. l1 46 | in 47 | (* scheme body *) 48 | let step (th1, th2, thd1, thd2) = 49 | let th1_next = th1 +. h *. thd1 50 | and th2_next = th2 +. h *. thd2 51 | and thd1_next, thd2_next = 52 | let dth = th1 -. th2 in 53 | let divider = l *. (1. -. m *. cos2 dth) in 54 | let denom1 = omega_squared *. l *. (-1. *. sin th1 +. m *. cos dth *. sin th2) -. m *. l *. (thd1 ** 2. *. cos dth +. l *. thd2 ** 2.) *. sin dth 55 | and denom2 = omega_squared *. (cos dth *. sin th1 -. sin th2) +. (thd1 ** 2. +. m *. l *. thd2 ** 2.) *. sin dth 56 | in 57 | thd1 +. h *. denom1 /. divider, thd2 +. h *. denom2 /. divider 58 | in 59 | (th1_next, th2_next, thd1_next, thd2_next) 60 | in 61 | let rec aux turn x = 62 | if turn <= 0 then () 63 | else 64 | let next = step x in 65 | print out_ch (m1, m2) (l1, l2) gravity next; 66 | aux (turn - 1) next 67 | in 68 | aux turn (th1, th2, thd1, thd2) 69 | -------------------------------------------------------------------------------- /differentialEquation/symplecticEuler.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let rec newton f f' x tol = 4 | let fx = f x in 5 | if abs_float fx < tol then x 6 | else newton f f' (x -. fx /. f' x) tol 7 | 8 | let tol = 1e-13 9 | 10 | let cos2 x = cos x ** 2. 11 | 12 | let to_general_coord (m1, m2) (l1, l2) (th1, th2, thd1, thd2) = 13 | let q1, q2 = th1, th2 14 | and a11 = (m1 +. m2) *. l1 ** 2. 15 | and a12 = m2 *. l1 *. l2 *. cos (th1 -. th2) 16 | and a22 = m2 *. l2 ** 2. 17 | in 18 | let p1 = a11 *. thd1 +. a12 *. thd2 19 | and p2 = a12 *. thd1 +. a22 *. thd2 20 | in 21 | (q1, q2, p1, p2) 22 | 23 | let of_general_coord (m1, m2) (l1, l2) (q1, q2, p1, p2) = 24 | let th1, th2 = q1, q2 in 25 | let thd = th1 -. th2 in 26 | let divider = (m2 *. l1 *. l2) ** 2. *. ((m1 +. m2) /. m2 -. cos2 thd) 27 | in 28 | let b11 = m2 *. l2 ** 2. /. divider 29 | and b12 = -1. *. m2 *. l1 *. l2 *. cos thd /. divider 30 | and b22 = (m1 +. m2) *. l1 ** 2. /. divider 31 | in 32 | let thd1 = b11 *. p1 +. b12 *. p2 33 | and thd2 = b12 *. p1 +. b22 *. p2 34 | in 35 | (th1, th2, thd1, thd2) 36 | 37 | let energy (m1, m2) (l1, l2) gravity (th1, th2, thd1, thd2) = 38 | let t = 0.5 *. m1 *. (l1 *. thd1) ** 2. +. 0.5 *. m2 *. ((l1 *. thd1) ** 2. +. (l2 *. thd2) ** 2. +. 2. *. l1 *. l2 *. thd1 *. thd2 *. cos (th1 -. th2)) 39 | and u = -1. *. m1 *. l1 *. gravity *. cos th1 -. m2 *. gravity *. (l1 *. cos l1 +. l2 *. cos l2) 40 | in 41 | t +. u 42 | 43 | let rec normalize theta = 44 | if abs_float theta < pi then theta 45 | else if theta > 0. then normalize (theta -. 2. *. pi) 46 | else normalize (theta +. 2. *. pi) 47 | 48 | let print out_ch m l gravity ((q1, q2, p1, p2) as x) = 49 | let (th1, th2, thd1, thd2) as c = of_general_coord m l x in 50 | let energy = energy m l gravity c in 51 | if abs_float thd1 < 0.1 then Printf.fprintf out_ch "%f %f %f %f %f\n" (normalize th1) (normalize th2) thd1 thd2 energy 52 | 53 | let main turn (m1, m2) (l1, l2) gravity h (theta1, theta2, theta_dot1, theta_dot2) out_ch = 54 | Printf.fprintf out_ch "# tol_of_newton : %e, weight : (%f, %f) length : (%f, %f) gravity : %f stepsize : %f num_step : %d init : (%f, %f, %f, %f)\n" tol m1 m2 l1 l2 gravity h turn theta1 theta2 theta_dot1 theta_dot2; 55 | (* calculate sub constants *) 56 | let m = m1 +. m2 in 57 | let coef1 = h /. (l1 *. l1) 58 | and coef2 = (h *. m) /. (m2 *. l2 *. l2) 59 | and coef3 = h /. (l1 *. l2) 60 | and f1 (q1, q2, p1, p2) qd = l2 *. p1 -. l1 *. p2 *. cos qd 61 | and f2 (q1, q2, p1, p2) qd = l1 *. m *. p2 -. m2 *. l2 *. p1 *. cos qd 62 | and g qd = m -. m2 *. cos2 qd 63 | in 64 | (* initialize generalized coordinates *) 65 | let (q1, q2, p1, p2) = to_general_coord (m1, m2) (l1, l2) (theta1, theta2, theta_dot1, theta_dot2) in 66 | (* scheme body *) 67 | let step ((q1, q2, p1, p2) as x) = 68 | let kappa = coef1 *. p1 -. coef2 *. p2 69 | and lambda = coef3 *. (p1 -. p2) 70 | in 71 | let f qd = q1 -. q2 +. (kappa +. lambda *. cos qd) /. (m -. m2 *. cos2 qd) -. qd 72 | and f' qd = (-1. *. kappa *. m2 *. sin (2. *. qd) -. lambda *. m *. sin qd -. lambda *. m2 *. sin qd *. cos2 qd) /. (m -. m2 *. cos2 qd) ** 2. -. 1. 73 | in 74 | let qd = newton f f' (q1 -. q2) tol in 75 | let (f1, f2, g) = f1 x qd, f2 x qd, g qd in 76 | let q1_next = q1 +. h *. f1 /. (l1 *. l1 *. l2 *. g) 77 | and q2_next = q2 +. h *. f2 /. (m2 *. l1 *. l2 *. l2 *. g) 78 | in 79 | let p1_next, p2_next = 80 | let t = (f1 *. f2 *. sin qd) /. (l1 *. l2 *. g) ** 2. in 81 | p1 -. h *. (t +. m *. l1 *. gravity *. sin q1_next), p2 +. h *. (t -. m2 *. l2 *. gravity *. sin q2_next) 82 | in 83 | (q1_next, q2_next, p1_next, p2_next) 84 | in 85 | let rec aux turn x = 86 | if turn <= 0 then () 87 | else 88 | let next = step x in 89 | print out_ch (m1, m2) (l1, l2) gravity next; 90 | aux (turn - 1) next 91 | in 92 | aux turn (q1, q2, p1, p2) 93 | -------------------------------------------------------------------------------- /differentialEquation/test.ml: -------------------------------------------------------------------------------- 1 | (* simulate duplex pendulum by symplectic euler method *) 2 | 3 | Printf.printf "evaluate 'test_euler n outname' or 'test_symplectic n outname'. n is a step size and outname is an output file name. If you set outname empty string, result appeares in stdout.\n";; 4 | 5 | let h = 0.001 (* step size *) 6 | let (m1, m2) = 0.5, 0.3 (* weight *) 7 | let (l1, l2) = 0.5, 0.5 (* length *) 8 | let gravity = 9.8 (* gravity acceleration *) 9 | let x0 = (3.0, 0., 0., 0.) (* init theta1, theta2, speed of theta1, speed of theta2 *) 10 | 11 | let test_euler n outname = 12 | let out = if outname = "" then stdout else open_out outname in 13 | Euler.main n (m1, m2) (l1, l2) gravity h x0 out; 14 | if outname = "" then () else close_out out 15 | 16 | let test_symplectic n outname = 17 | let out = if outname = "" then stdout else open_out outname in 18 | SymplecticEuler.main n (m1, m2) (l1, l2) gravity h x0 out; 19 | if outname = "" then () else close_out out 20 | -------------------------------------------------------------------------------- /dijkstra/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /dijkstra/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCAMLINCLUDES += ../graph 8 | OCAML_LIBS[] += ../graph/graph 9 | 10 | OCamlProgram($(PROGRAM), $(FILES)) 11 | 12 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 13 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 14 | 15 | .PHONY: clean 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 19 | $(PROGRAM).run $(PROGRAM).opt 20 | -------------------------------------------------------------------------------- /dijkstra/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Graph 3 | module G = UndirectedGraph 4 | 5 | exception Found 6 | 7 | let dijkstra s t g = 8 | let dists = Array.make (G.size g) infinity 9 | and preds = Array.make (G.size g) None 10 | and are_fixed = Array.make (G.size g) false in 11 | let filter_unfixed = List.filter (fun n -> not are_fixed.(n)) in 12 | dists.(0) <- 0.; are_fixed.(0) <- true; 13 | let rec dijkstra_aux neighbor = 14 | if IntSet.is_empty neighbor then raise (Invalid_argument "There is no s-t pass.") 15 | else 16 | let dist_traceable u h = G.get (h, u) g +. dists.(h), h in 17 | let node_and_dist = List.map 18 | (fun u -> (u, List.find_min_val (dist_traceable u) (G.heads_of u g))) 19 | (IntSet.elements neighbor) 20 | in 21 | let (to_fix, (d, h)) = List.find_min snd node_and_dist in 22 | dists.(to_fix) <- d; preds.(to_fix) <- Some h; are_fixed.(to_fix) <- true; 23 | if to_fix = t then raise Found; 24 | let update u v = 25 | let new_dist = dists.(u) +. G.get (u, v) g in 26 | if dists.(v) > new_dist then begin dists.(v) <- new_dist; preds.(v) <- Some u; end 27 | in 28 | List.iter (update to_fix) (G.tails_of to_fix g |> filter_unfixed); 29 | let new_neighbor = IntSet.add_list (IntSet.remove to_fix neighbor) (G.tails_of to_fix g |> filter_unfixed) 30 | in 31 | dijkstra_aux new_neighbor 32 | in 33 | try dijkstra_aux (IntSet.add_list IntSet.empty (G.tails_of s g)) with 34 | Found -> 35 | let rec trace accum n = match preds.(n) with 36 | None -> accum 37 | | Some m -> trace (m :: accum) m 38 | in 39 | dists.(t), trace [t] t 40 | 41 | -------------------------------------------------------------------------------- /dijkstra/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Graph 3 | open Main 4 | 5 | let g = G.empty 6;; 6 | G.add (0, 1) 7. g;; 7 | G.add (0, 5) 14. g;; 8 | G.add (0, 2) 9. g;; 9 | G.add (1, 2) 10. g;; 10 | G.add (1, 3) 15. g;; 11 | G.add (2, 3) 10. g;; 12 | G.add (2, 5) 2. g;; 13 | G.add (3, 4) 6. g;; 14 | G.add (4, 5) 9. g;; 15 | let d = dijkstra 0 4 g 16 | -------------------------------------------------------------------------------- /eratosthenes/.ocamlinit: -------------------------------------------------------------------------------- 1 | #load "bigarray.cma" 2 | #directory "../util" 3 | #load "util.cma" 4 | #load "main.cmo" 5 | #use "./test.ml" -------------------------------------------------------------------------------- /eratosthenes/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCAML_OTHER_LIBS += bigarray 8 | 9 | OCamlProgram($(PROGRAM), $(FILES)) 10 | 11 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 12 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 13 | 14 | .PHONY: clean 15 | clean: 16 | rm -f \ 17 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 18 | $(PROGRAM).run $(PROGRAM).opt 19 | -------------------------------------------------------------------------------- /eratosthenes/README: -------------------------------------------------------------------------------- 1 | ・エラトステネスの篩.計算量O(N^1.5). 2 | ・それっぽく書こうと思ってわざわざSetを使っているが,素直に配列で書けばO(sum_{i=2}^{sqrt N} (N/i))=O(NlogN)なのでそっちの方がよい. 3 | ・というわけで追加した. 4 | -------------------------------------------------------------------------------- /eratosthenes/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open IntSet 3 | 4 | let eratosthenes n = 5 | let rec eratosthenes_aux primes remains = 6 | let minimum = min_elt remains in 7 | if minimum * minimum > (max_elt remains) then 8 | union primes remains 9 | else 10 | eratosthenes_aux (add minimum primes) (filter (fun m -> m mod minimum <> 0) remains) 11 | in 12 | List.range 3 n 2 |> add_list (singleton 2) |> eratosthenes_aux empty |> elements 13 | 14 | open Bigarray;; 15 | 16 | let eratosthenes_better n = (* more fast *) 17 | let nums = Array1.create int c_layout (n + 1) in 18 | for i = 0 to n do 19 | Array1.set nums i i 20 | done; 21 | let term = sqrt (float n) |> int_of_float |> ( + ) 1 in 22 | let rec aux m j = 23 | if j > n then () 24 | else let _ = Array1.set nums j 0 in aux m (j + m) 25 | in 26 | let rec aux2 k = 27 | if k > term then () 28 | else let _ = aux k (2 * k) in aux2 (k + 1) 29 | in 30 | let _ = aux2 2 in 31 | let rec make_ans i accum = 32 | if i = 0 then accum 33 | else make_ans (i - 1) (let j = Array1.get nums i in if j = 0 then accum else j :: accum) 34 | in 35 | make_ans n [] |> List.filter ((<>) 0) |> List.tl 36 | -------------------------------------------------------------------------------- /eratosthenes/test.ml: -------------------------------------------------------------------------------- 1 | open Util;; 2 | if Array.length Sys.argv < 2 || int_of_string Sys.argv.(1) < 2 then 3 | Printf.printf "input some integer > 1\n" 4 | else 5 | let n = Sys.argv.(1) |> int_of_string in 6 | Main.eratosthenes n |> List.print_int_list 7 | -------------------------------------------------------------------------------- /ford-fulkerson/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /ford-fulkerson/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCAMLINCLUDES += ../graph 8 | OCAML_LIBS[] += ../graph/graph 9 | 10 | OCamlProgram($(PROGRAM), $(FILES)) 11 | 12 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 13 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 14 | 15 | .PHONY: clean 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 19 | $(PROGRAM).run $(PROGRAM).opt 20 | -------------------------------------------------------------------------------- /ford-fulkerson/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | module G = Graph.DirectedGraph 3 | 4 | let make_flow_network g = 5 | let g2 = G.map (fun c -> (0, c)) g in 6 | let reverse (h, t) c = if not (G.exists (t, h) g) then G.add (t, h) (0, 0) g2 in 7 | G.itere reverse g2; g2 8 | 9 | let max_flow s t g = 10 | let g = make_flow_network g in 11 | let rec max_flow_aux flow = 12 | try 13 | let aug_path = G.find_path s t (fun (f, c) -> c - f > 0) g in 14 | let aug_path_chain = List.to_chain aug_path in 15 | let bottleneck = 16 | let (f1, c1) = (G.get (List.hd aug_path_chain) g) in 17 | G.fold_through (fun r e (f, c) -> min r (c - f)) (c1 - f1) aug_path g 18 | in 19 | Printf.printf "augmenting path found : "; List.print_int_list aug_path; 20 | Printf.printf "(max flow : %d)\n" bottleneck; 21 | G.map_through (fun (f, c) -> (f + bottleneck, c)) aug_path g; 22 | G.map_through (fun (f, c) -> (f - bottleneck, c)) (List.rev aug_path) g; 23 | max_flow_aux (flow + bottleneck) 24 | with Not_found -> flow 25 | in 26 | max_flow_aux 0 27 | -------------------------------------------------------------------------------- /ford-fulkerson/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | module G = Graph.DirectedGraph 3 | 4 | let g = G.empty 7;; 5 | G.add (0, 3) 3 g;; 6 | G.add (0, 1) 3 g;; 7 | G.add (2, 0) 3 g;; 8 | G.add (1, 2) 4 g;; 9 | G.add (2, 3) 1 g;; 10 | G.add (2, 4) 2 g;; 11 | G.add (4, 1) 1 g;; 12 | G.add (3, 4) 2 g;; 13 | G.add (3, 5) 6 g;; 14 | G.add (4, 6) 1 g;; 15 | G.add (5, 6) 9 g;; 16 | Main.max_flow 0 6 g |> Printf.printf "total max flow : %d\n" 17 | 18 | -------------------------------------------------------------------------------- /geometry/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /geometry/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCamlProgram($(PROGRAM), $(FILES)) 8 | 9 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 10 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 11 | 12 | .PHONY: clean 13 | clean: 14 | rm -f \ 15 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 16 | $(PROGRAM).run $(PROGRAM).opt 17 | -------------------------------------------------------------------------------- /geometry/README: -------------------------------------------------------------------------------- 1 | ・概要 2 | 平面幾何用モジュール.点は浮動小数点の組で表される(このため意地の悪い問題に対してはこける可能性がある). 3 | 4 | ・convex_hull : 点数Nに対し最良O(N),平均O(NlogN) 5 | Andrewの凸包走査.x座標で整列したのち,一番左の点から凸包の上側を,一番右の点から凸包の下側を構成し,最後に合成する.凸包の上側の構成は,一つ右側の点を加え,直近の3点を見て(ccwを利用)左回りであれば,それらの真ん中の点が凸包の線より下側にあることが分かるのでこれを取り除くという操作の繰り返しによる.下側の構成も同様. 6 | -------------------------------------------------------------------------------- /geometry/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type direction = Left | Right | Center (* CounterClokWise | ClockWise | Line *) 4 | type point2D = float * float 5 | type line = point2D * point2D 6 | 7 | module Point2D = struct 8 | type t = point2D 9 | let ( +^ ) (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2) 10 | let ( -^ ) (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2) 11 | let dot (x1, y1) (x2, y2) = x1 *. x2 +. y1 *. y2 12 | let cross (x1, y1) (x2, y2) = x1 *. y2 -. y1 *. x2 13 | let compare (x1, y1) (x2, y2) = compare x1 x2 * 2 + compare y1 y2 14 | let ccw a b c = 15 | let d = cross (b -^ a) (c -^ a) in 16 | if d > 0. then Left 17 | else if d < 0. then Right 18 | else Center 19 | end 20 | 21 | module Point2DSet' = Set.Make(Point2D) 22 | module Point2DSet = struct 23 | include Point2DSet' 24 | let add_list = List.fold_left (swap_arg Point2DSet'.add) 25 | let remove_min s = 26 | let min = Point2DSet'.min_elt s in 27 | (min, Point2DSet'.remove min s) 28 | let remove_max s = 29 | let max = Point2DSet'.max_elt s in 30 | (max, Point2DSet'.remove max s) 31 | end 32 | 33 | let convex_hull points = 34 | let get3 r = try 35 | let (c, r) = List.hd r, List.tl r in 36 | let (b, r) = List.hd r, List.tl r in 37 | let a = List.hd r in 38 | (a, b, c) 39 | with 40 | Failure "hd" -> raise Not_found 41 | in 42 | let rec getout hull = 43 | try 44 | let (a, b, c) = get3 hull in 45 | if Point2D.ccw a b c = Left then getout (List.delete_nth_naive 1 hull) 46 | else hull 47 | with Not_found -> hull 48 | and aux is_upper pointset hull = 49 | if Point2DSet.is_empty pointset then 50 | hull 51 | else 52 | let (m, r) = 53 | (if is_upper then Point2DSet.remove_min else Point2DSet.remove_max) pointset 54 | in 55 | aux is_upper r (getout (m :: hull)) 56 | in 57 | let pointset = Point2DSet.add_list Point2DSet.empty points in 58 | let upper_hull = 59 | let (p0, removed) = Point2DSet.remove_min pointset in 60 | let (p1, removed) = Point2DSet.remove_min removed in 61 | aux true removed [p1;p0] 62 | and lower_hull = 63 | let (p0, removed) = Point2DSet.remove_max pointset in 64 | let (p1, removed) = Point2DSet.remove_max removed in 65 | aux false removed [p1;p0] 66 | in 67 | lower_hull @ (List.tl upper_hull) 68 | 69 | -------------------------------------------------------------------------------- /geometry/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let points1 = [(0., 3.);(-3., 2.);(-1., 1.);(2., 1.);(-4., 0.);(0., 0.);(3., -1.);(-2., -2.);(1., -2.)] 4 | let convex1 = Main.convex_hull points1 5 | -------------------------------------------------------------------------------- /graph/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util" 2 | #use "./test.ml" -------------------------------------------------------------------------------- /graph/OMakefile: -------------------------------------------------------------------------------- 1 | # UbiGraph, xmlrpc-light and Ubigraph.ml(likely contained in xmlrpc-light package) are needed. 2 | # You can obtain the custom ocaml toplevel named "ubigraphtop", which enables interactive graph visualization with UbiGraph, by `omake mktop`. Before running ubigraphtop you should launch UbiGraph server. test.ml will be not compiled by omake but loaded in ubigraphtop automaticaly(see .ocamlinit). 3 | 4 | FILES[] = 5 | graph 6 | # Ubigraph 7 | # draw 8 | 9 | #OCAMLPACKS[] = xmlrpc-light 10 | 11 | LIB = graph 12 | 13 | .DEFAULT: $(OCamlLibrary $(LIB), $(FILES)) 14 | 15 | .PHONY: clean mktop 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) 19 | #mktop: 20 | # ocamlfind ocamlmktop -I ../util -o ubigraphtop -package xmlrpc-light,findlib -linkpkg -custom util.cmo Ubigraph.cmo graph.cmo draw.cmo 21 | -------------------------------------------------------------------------------- /graph/README: -------------------------------------------------------------------------------- 1 | ・隣接リスト表現によるグラフモジュール.可視化用に要xmlrpc-light及びUbigraph.ml. 2 | ・0から始まる頂点番号をインデックスとする配列の各要素に,その頂点に隣接する頂点の番号及びそれらを結ぶ枝の重みのペアのリストが格納される.よって頂点へのアクセスコストはO(1),枝へのアクセスコストはグラフの形状に依存する. 3 | ・隣接行列表現はそのうちやる. -------------------------------------------------------------------------------- /graph/draw.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module Make(G : Graph.Graph) = struct 4 | let client = new Ubigraph.client "http://localhost:20738/RPC2" 5 | let u = client#ubigraph 6 | 7 | let draw to_string g = (* stub : only nodes yet *) 8 | u#clear (); 9 | let make_assoc i = 10 | let v = u#new_vertex () in 11 | u#set_vertex_attribute v "label" (string_of_int i); 12 | u#set_vertex_attribute v "fontcolor" "#ff3333"; 13 | u#set_vertex_attribute v "fontsize" "18"; 14 | (i, v) 15 | in 16 | let vertexes = List.map make_assoc (G.nodes g) in 17 | let join ((i, j), w) = 18 | let e = u#new_edge (List.assoc i vertexes) (List.assoc j vertexes) in 19 | u#set_edge_attribute e "label" (to_string w); 20 | u#set_edge_attribute e "width" "3.0"; 21 | u#set_edge_attribute e "color" "#ffffff"; 22 | u#set_edge_attribute e "fontcolor" "#33cc66"; 23 | u#set_edge_attribute e "fontsize" "18"; 24 | () 25 | in 26 | List.iter join (G.edges g) 27 | end 28 | -------------------------------------------------------------------------------- /graph/graph.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type edge = int * int 4 | type path = int list 5 | 6 | module type Graph = sig 7 | 8 | (** The type of graphs. *) 9 | type 'a t 10 | 11 | (** empty n returns a graph with at most n nodes and no edge. *) 12 | val empty : int -> 'a t 13 | 14 | (** Test whether a graph has no edge or not. *) 15 | val is_empty : 'a t -> bool 16 | 17 | val size : 'a t -> int 18 | val exists : edge -> 'a t -> bool 19 | val add : edge -> 'a -> 'a t -> unit 20 | val singleton : int -> edge -> 'a -> 'a t 21 | val copy : 'a t -> 'a t 22 | 23 | (** unite g1 g2 adds all edges of g1 to g2. *) 24 | val unite : 'a t -> 'a t -> unit 25 | val set : edge -> 'a -> 'a t -> unit 26 | val remove : edge -> 'a t -> unit 27 | val heads_of : int -> 'a t -> int list 28 | val tails_of : int -> 'a t -> int list 29 | val get : edge -> 'a t -> 'a 30 | val nodes : 'a t -> int list 31 | val edges : 'a t -> (edge * 'a) list 32 | val is_edge : edge -> 'a t -> bool 33 | 34 | (** num_share e g returns the number of endpoints that e shares with g. *) 35 | val num_share : edge -> 'a t -> int 36 | 37 | (** is_adjacent e g tests whether e shares an endpoint with g. *) 38 | val is_adjacent : edge -> 'a t -> bool 39 | 40 | (** find_path s 'a t p g finds a s-t path whose all edges satisfies p by BFS. 41 | Raises Not_found when there is no such a path. *) 42 | val find_path : int -> int -> ('a -> bool) -> 'a t -> path 43 | val fold_through : ('a -> edge -> 'b -> 'a) -> 'a -> path -> 'b t -> 'a 44 | val map_through : ('a -> 'a) -> path -> 'a t -> unit 45 | val map : ('a -> 'b) -> 'a t -> 'b t 46 | val mape : (edge -> 'a -> 'b) -> 'a t -> 'b t 47 | val iter : ('a -> unit) -> 'a t -> unit 48 | val itere : (edge -> 'a -> unit) -> 'a t -> unit 49 | end 50 | 51 | module BaseGraph : sig 52 | type 'a interedge = int * 'a 53 | type 'a t = 'a interedge list array 54 | val head : edge -> int 55 | val tail : edge -> int 56 | val dest : 'a interedge -> int 57 | val weight : 'a interedge -> 'a 58 | val is_endpoint : int -> 'a interedge -> bool 59 | val empty : int -> 'a t 60 | val is_empty : 'a t -> bool 61 | val size : 'a t -> int 62 | val exists : edge -> 'a t -> bool 63 | val add' : edge -> 'a -> 'a t -> unit 64 | val remove' : edge -> 'a t -> unit 65 | val copy : 'a t -> 'a t 66 | val heads_of : int -> 'a t -> int list 67 | val tails_of : int -> 'a t -> int list 68 | val head_nodes : 'a t -> int list 69 | val tail_nodes : 'a t -> int list 70 | val get : edge -> 'a t -> 'a 71 | val adjacents : int -> 'a t -> 'a interedge list 72 | val is_edge : edge -> 'a t -> bool 73 | val find_path : int -> int -> ('a -> bool) -> 'a t -> path 74 | val path_exists : path -> 'a t -> bool 75 | val fold_through : ('b -> edge -> 'a -> 'b) -> 'b -> path -> 'a t -> 'b 76 | val map : ('a -> 'b) -> 'a t -> 'b t 77 | val mape : (edge -> 'a -> 'b) -> 'a t -> 'b t 78 | val iter : ('a -> unit) -> 'a t -> unit 79 | val itere : (edge -> 'a -> unit) -> 'a t -> unit 80 | end 81 | = struct 82 | type 'a interedge = int * 'a 83 | type 'a t = 'a interedge list array 84 | let head (e : edge) = fst e 85 | let tail (e : edge) = snd e 86 | let dest (x : 'a interedge) = fst x 87 | let weight (x : 'a interedge) = snd x 88 | let is_endpoint p x = dest x = p 89 | let empty n = Array.make n [] 90 | let is_empty g = Array.for_all List.is_empty g 91 | let size = Array.length 92 | let exists (h, t) g = List.exists (is_endpoint t) g.(h) 93 | let add' (h, t) w g = g.(h) <- (t, w) :: g.(h) 94 | let remove' (h, t) g = g.(h) <- List.remove (is_endpoint t) g.(h) 95 | let copy = Array.copy 96 | let heads_of t g = Array.to_list g 97 | |> List.mapi (fun i l -> if List.exists (fun x -> dest x = t) l then Some i else None) 98 | |> List.filter_some 99 | let tails_of h g = List.map dest g.(h) 100 | let head_nodes g = Array.to_list g 101 | |> List.mapi (fun i dests -> match dests with [] -> None | _ -> Some i) 102 | |> List.filter_some 103 | let tail_nodes g = Array.to_list g 104 | |> List.flatten |> List.split |> fst |> IntSet.add_list IntSet.empty |> IntSet.elements 105 | let get (h, t) g = List.find (is_endpoint t) g.(h) |> weight 106 | let adjacents h g = g.(h) 107 | let is_edge e g = List.exists (fun x -> dest x = tail e) g.(head e) 108 | exception Found 109 | let find_path s t p g = 110 | let path_table = Array.make (size g) None in 111 | let rec find_path_aux to_search = 112 | if Stack2.is_empty to_search then raise Not_found 113 | else 114 | let (u, rest) = Stack2.pop to_search in 115 | let test q (v, w) = 116 | if p w && path_table.(v) = None then begin 117 | path_table.(v) <- Some u; 118 | if v = t then raise Found else Stack2.push v q 119 | end 120 | else q 121 | in 122 | find_path_aux (List.fold_left test rest (adjacents u g)) 123 | in 124 | try find_path_aux (Stack2.singleton s) with 125 | Found -> 126 | let rec rebuild_path v accum = match path_table.(v) with 127 | Some u -> if u = s then s :: accum else rebuild_path u (u :: accum) 128 | | None -> failwith "find_path : fatal error" 129 | in 130 | rebuild_path t [t] 131 | let path_exists path g = 132 | let rec path_exists_aux = function 133 | [] -> true 134 | | hd :: tl -> if exists hd g then path_exists_aux tl else false 135 | in 136 | path_exists_aux (List.to_chain path) 137 | let fold_through f x path g = 138 | if not (path_exists path g) then raise (Invalid_argument "That path does not exist in the graph."); 139 | let rec fold_through_aux x = function 140 | [] -> x 141 | | hd :: tl -> fold_through_aux (f x hd (get hd g)) tl 142 | in 143 | fold_through_aux x (List.to_chain path) 144 | let map f g = 145 | let rec map_aux accum = function 146 | [] -> accum 147 | | (t, w) :: tl -> map_aux ((t, f w) :: accum) tl 148 | in 149 | Array.map (map_aux []) g 150 | let mape f g = 151 | let rec map_aux accum h = function 152 | [] -> accum 153 | | (t, w) :: tl -> map_aux ((t, f (h, t) w) :: accum) h tl 154 | in 155 | Array.mapi (map_aux []) g 156 | let iter f g = 157 | let rec iter_aux = function 158 | [] -> () 159 | | (t, w) :: tl -> f w; iter_aux tl 160 | in 161 | Array.iter iter_aux g 162 | let itere f g = 163 | let rec iter_aux h = function 164 | [] -> () 165 | | (t, w) :: tl -> f (h, t) w; iter_aux h tl 166 | in 167 | Array.iteri iter_aux g 168 | end 169 | 170 | 171 | (* loop and multigraph are prohibited *) 172 | module DirectedGraph : Graph 173 | = struct 174 | include BaseGraph 175 | let add e w g = 176 | if exists e g then raise (Invalid_argument "add : edge already exists."); 177 | add' e w g 178 | let singleton n e w = let g = empty n in add e w g; g 179 | let edges g = Array.to_list g 180 | |> List.mapi (fun i xs -> List.map (fun x -> ((i, dest x), weight x)) xs) 181 | |> List.flatten 182 | let unite g1 g2 = edges g1 183 | |> List.iter (fun(t, w) -> 184 | try add t w g2 185 | with Invalid_argument _ -> raise (Invalid_argument "unite : edge overlapping.")) 186 | let set e w g = 187 | if exists e g = false then raise (Invalid_argument "set : edge doesn't exists."); 188 | remove' e g; 189 | add' e w g 190 | let remove e g = 191 | remove' e g 192 | let nodes g = IntSet.add_list (IntSet.add_list IntSet.empty (head_nodes g)) (tail_nodes g) |> IntSet.elements 193 | let num_share (h, t) g = List.count (fun n -> n = h || n = t) (nodes g) 194 | let is_adjacent e g = 195 | num_share e g > 0 && 196 | not (is_edge e g) && 197 | not (is_edge (swap e) g) 198 | let map_through f path g = 199 | if not (path_exists path g) then raise (Invalid_argument "That path does not exist in the graph."); 200 | let rec map_through_aux = function 201 | [] -> () 202 | | hd :: tl -> set hd (get hd g |> f) g; map_through_aux tl 203 | in 204 | map_through_aux (List.to_chain path) 205 | end 206 | 207 | module UndirectedGraph : Graph = struct 208 | include BaseGraph 209 | let exists e g = exists e g || exists (swap e) g 210 | let add e w g = 211 | if exists e g then raise (Invalid_argument "add : edge already exists"); 212 | add' e w g; 213 | add' (swap e) w g 214 | let singleton n e w = let g = empty n in add e w g; g 215 | let edges g = Array.to_list g 216 | |> List.mapi (fun i xs -> List.map 217 | (fun x -> if i < dest x then Some ((i, dest x), weight x) else None) 218 | xs) 219 | |> List.flatten 220 | |> List.filter_some 221 | let unite g1 g2 = edges g1 222 | |> List.iter (fun (t, w) -> 223 | try add t w g2 224 | with Invalid_argument _ -> raise (Invalid_argument "unite : edge overlapping.")) 225 | let set e w g = 226 | if exists e g = false then raise (Invalid_argument "set : edge doesn't exists"); 227 | remove' e g; 228 | remove' (swap e) g 229 | let remove e g = 230 | remove' e g; 231 | remove' (swap e) g 232 | let nodes = head_nodes 233 | let num_share (h, t) g = List.count (fun n -> n = h || n = t) (nodes g) 234 | let is_adjacent e g = 235 | num_share e g > 0 && not (is_edge e g) 236 | let map_through f path g = 237 | if not (path_exists path g) then raise (Invalid_argument "That path does not exist in the graph."); 238 | let rec map_through_aux = function 239 | [] -> () 240 | | hd :: tl -> set hd (get hd g |> f) g; map_through_aux tl 241 | in 242 | map_through_aux (List.to_chain path) 243 | end 244 | 245 | 246 | 247 | -------------------------------------------------------------------------------- /graph/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Graph 3 | 4 | let g1 = DirectedGraph.empty 5;; 5 | DirectedGraph.add (3, 2) "a" g1;; 6 | DirectedGraph.add (2, 4) "a" g1;; 7 | DirectedGraph.add (3, 4) "a" g1;; 8 | 9 | let g2 = DirectedGraph.empty 5;; 10 | DirectedGraph.add (0, 1) "b" g2;; 11 | DirectedGraph.add (0, 2) "b" g2;; 12 | DirectedGraph.add (1, 2) "b" g2;; 13 | 14 | DirectedGraph.unite g1 g2;; 15 | 16 | (* module D = Draw.Make(DirectedGraph);; 17 | D.draw identity g2 *) 18 | -------------------------------------------------------------------------------- /knapsack/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /knapsack/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | 8 | OCamlProgram($(PROGRAM), $(FILES)) 9 | 10 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 11 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 12 | 13 | .PHONY: clean 14 | clean: 15 | rm -f \ 16 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 17 | $(PROGRAM).run $(PROGRAM).opt 18 | -------------------------------------------------------------------------------- /knapsack/README: -------------------------------------------------------------------------------- 1 | ナップサック問題=価値v_iと容積w_iの組で表されるN個の品物を,合計容積がWを越えないように組み合わせて合計価値を最大化する問題を解く.合計価値の目標値Kを設定した判定版を考えると,これはv_i=w_i,W=K=(1/2)sum{w_i}の制限により分割問題PARTITIONの一般化であること,従ってNP完全であることが分かる.この実装は合計容積制限が0,1,2,...,Wの場合の最適解を順に構築していく動的計画法による擬多項式時間O(NW)のアルゴリズムである. -------------------------------------------------------------------------------- /knapsack/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module Goods = struct 4 | (** (weight, value) *) 5 | type t = int * int 6 | 7 | (** compares primarily which is heavier and secondary which is cheaper. 8 | Therefore lightest and most expensive one comes first when sorted by this function. *) 9 | let compare (w1, v1) (w2, v2) = 10 | Pervasives.compare w1 w2 * 2 - Pervasives.compare v1 v2 11 | end 12 | 13 | module GoodsSet = Set.Make(Goods) 14 | 15 | let print_goods gs = 16 | GoodsSet.iter (fun g -> Printf.printf "(%d, %d) " (fst g) (snd g)) gs; 17 | Printf.printf "\n" 18 | 19 | let opt capacity goods = 20 | let goodsSet = List.fold_left (fun set elt -> 21 | if (fst elt < 0 || snd elt < 0) then raise (Invalid_argument "Value and weight must not be negative.") 22 | else GoodsSet.add elt set) GoodsSet.empty goods 23 | in 24 | (* main part of DP. opt_log is a list of (total value, remained goods) and the nth element represents the optimum and the optimal solution in n+1 less capacity than current. *) 25 | let rec opt_aux capacity opt_log = 26 | (* debug *) 27 | (* 28 | List.iter (fun opt -> 29 | Printf.printf "%d" (fst opt); 30 | print_goods (GoodsSet.diff goodsSet (snd opt)) 31 | ) opt_log; 32 | Printf.printf "\n"; *) 33 | if capacity <= 0 || GoodsSet.is_empty (snd (List.hd opt_log)) then (* termination *) 34 | opt_log 35 | else 36 | (* At first, choice n+1 lighter goods from remained goods at opt in n+1 less capacity. 37 | Then return None when not found and otherwise return the most expensive one. *) 38 | let to_add n remained = 39 | let addable = (GoodsSet.filter (fun g -> fst g = n + 1) remained) in 40 | if GoodsSet.is_empty addable then None 41 | else Some (GoodsSet.min_elt addable) 42 | in 43 | let add_good n (value, remained) = match to_add n remained with 44 | None -> (value, remained) 45 | | Some g -> (value + snd g, GoodsSet.remove g remained) 46 | in 47 | (* Make candidates for opt in current capacity by mapping add_good. 48 | and choice from them by total value *) 49 | let new_opt = List.find_max fst (List.mapi add_good opt_log) in 50 | opt_aux (capacity - 1) (new_opt :: opt_log) 51 | in 52 | opt_aux capacity [(0, goodsSet)] |> List.hd |> snd |> GoodsSet.diff goodsSet |> GoodsSet.elements 53 | -------------------------------------------------------------------------------- /knapsack/main.mli: -------------------------------------------------------------------------------- 1 | val opt : int -> (int * int) list -> (int * int) list 2 | -------------------------------------------------------------------------------- /knapsack/test.ml: -------------------------------------------------------------------------------- 1 | let capacity = 20 2 | 3 | let goods = [(1, 2); (1, 1); (2, 2); (2, 3); (3, 2); (3, 6); (5, 5); (5, 7); (6, 10); (6, 4); (9, 11); (10, 12); (10, 9); (11, 15)] 4 | 5 | let solution = Main.opt capacity goods 6 | 7 | let _ = 8 | List.iter (fun x -> Printf.printf "(%d, %d) " (fst x) (snd x)) solution; 9 | Printf.printf "\n" 10 | -------------------------------------------------------------------------------- /kruskal/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /kruskal/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCAMLINCLUDES += ../graph 8 | OCAML_LIBS[] += ../graph/graph 9 | 10 | OCamlProgram($(PROGRAM), $(FILES)) 11 | 12 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 13 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 14 | 15 | .PHONY: clean 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 19 | $(PROGRAM).run $(PROGRAM).opt 20 | -------------------------------------------------------------------------------- /kruskal/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Graph 3 | open UndirectedGraph 4 | 5 | 6 | 7 | let kruskal g = 8 | let size = UndirectedGraph.size g in 9 | let rec kruskal_aux edges gs = match edges with 10 | [] -> List.hd gs 11 | | min :: rest -> 12 | let (min_edge, min_weight) = min in 13 | let adjs = List.filter (UndirectedGraph.is_adjacent min_edge) gs in 14 | Printf.printf "add (%d, %d) %d\n" (fst min_edge) (snd min_edge) min_weight; 15 | match let n = List.length adjs in Printf.printf "#adjs = %d\n" n; n with 16 | 0 -> kruskal_aux rest (UndirectedGraph.singleton size min_edge min_weight :: gs) 17 | | 1 -> begin let adj = List.single adjs in 18 | match UndirectedGraph.num_share min_edge adj with 19 | 1 -> UndirectedGraph.add min_edge min_weight adj; 20 | kruskal_aux rest gs 21 | | 2 -> kruskal_aux rest gs 22 | | _ -> failwith "fatal error" end 23 | | 2 -> let g1 = List.nth adjs 0 and g2 = List.nth adjs 1 in 24 | let g = UndirectedGraph.add min_edge min_weight g2 in 25 | let g = UndirectedGraph.unite g1 g2 in 26 | kruskal_aux rest (List.remove ((==) g1) gs)(* stub *) 27 | | _ -> failwith "fatal error" 28 | and edges = 29 | let compare e1 e2 = compare (snd e1) (snd e2) in 30 | UndirectedGraph.edges g |> List.sort compare in 31 | kruskal_aux edges [] 32 | 33 | -------------------------------------------------------------------------------- /kruskal/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Graph.UndirectedGraph 3 | open Main 4 | 5 | let g = empty 7;; 6 | add (0, 1) 7 g;; 7 | add (1, 2) 8 g;; 8 | add (2, 4) 5 g;; 9 | add (4, 1) 7 g;; 10 | add (1, 3) 9 g;; 11 | add (3, 4) 15 g;; 12 | add (3, 5) 6 g;; 13 | add (5, 4) 8 g;; 14 | add (4, 6) 9 g;; 15 | add (5, 6) 11 g;; 16 | 17 | 18 | let mst = kruskal g |> edges 19 | -------------------------------------------------------------------------------- /machineLearning/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "sequentialPrediction.cmo" -------------------------------------------------------------------------------- /machineLearning/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | sequentialPrediction 5 | 6 | OCamlProgram($(PROGRAM), $(FILES)) 7 | 8 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 9 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 10 | 11 | .PHONY: clean 12 | clean: 13 | rm -f \ 14 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 15 | $(PROGRAM).run $(PROGRAM).opt 16 | -------------------------------------------------------------------------------- /machineLearning/README: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LennMars/algorithms_in_OCaml/f7fb8ca9f497883d86be3167bfc98a4a28ac73c9/machineLearning/README -------------------------------------------------------------------------------- /machineLearning/sequentialPrediction.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let anon_fun s = "unknown argument: " ^ s |> print_endline 4 | (* options init *) 5 | let to_display = ref false 6 | let seed = ref 0 7 | let turn = ref 1 8 | let prob = ref 0.5 9 | let m = ref 10 10 | let spec_display = ("-d", Arg.Bool (fun x -> to_display := x), "") 11 | let spec_seed = ("-s", Arg.Int (fun x -> seed := x), "set seed") 12 | let spec_turn = ("-t", Arg.Int (fun x -> turn := x), "set turn") 13 | let spec_prob = ("-p", Arg.Float (fun x -> prob := x), "set prob") 14 | let spec_m = ("-m", Arg.Int (fun x -> m := x), "set m");; 15 | Arg.parse [spec_display; spec_seed; spec_turn; spec_prob; spec_m] anon_fun "";; 16 | Random.init !seed;; 17 | 18 | (* Sampling from binomial distribution whose #experiments is n and success probability is p. *) 19 | let rec binomial_generator m p () = 20 | let rec binomial_generator_aux m accum = 21 | if m <= 0 then 22 | accum 23 | else 24 | binomial_generator_aux (m - 1) (accum + if Random.float 1. < p then 1 else 0) 25 | in 26 | binomial_generator_aux m 0;; 27 | 28 | (* binomial coefficient C(n, k). *) 29 | let bin_coef n k = 30 | if n < k then raise (Invalid_argument "first arg too small"); 31 | let rec fact l accum = 32 | if l <= 1 then accum else fact (l - 1) (l * accum) 33 | in 34 | fact n 1 / fact k 1 / fact (n - k) 1 35 | 36 | let binomial_expectator m sequence current_value = 37 | let turn = List.length sequence + 1 38 | and past_sum = List.fold_left ( + ) 0 sequence in 39 | let estimated_prob x = float (past_sum + x) /. float (m * turn) in 40 | let max_likelihood_dist_point x = 41 | float (bin_coef m x) 42 | *. estimated_prob x ** float x 43 | *. (1. -. estimated_prob x) ** float (m - x) 44 | in 45 | let max_likelihood_dist x = 46 | List.fold_left ( *. ) 1. (List.map max_likelihood_dist_point (x :: sequence)) 47 | in 48 | let normalizer = List.fold_left (+.) 0. (List.init max_likelihood_dist (m + 1))in 49 | max_likelihood_dist current_value /. normalizer 50 | 51 | let negative_log_loss x = 52 | if x < 0. || x > 1. then raise (Invalid_argument "not probability"); 53 | (-1.) *. log x 54 | 55 | let main loss_func generator expectator turn = 56 | let rec main_aux total_loss sequence t = 57 | if t > turn then 58 | let min_total_loss = List.fold_left ( +. ) 0. 59 | (List.map (fun x -> loss_func (expectator sequence x)) sequence) 60 | and upper_bound_of_regret = float !m /. 2. *. (log (float turn +. 1.) +. 1.) in 61 | Printf.printf "regret : %f, upper_bound : %f\n" 62 | (total_loss -. min_total_loss) upper_bound_of_regret 63 | else 64 | let current_value = generator () in 65 | let loss = loss_func (expectator sequence current_value) in 66 | if !to_display then Printf.printf "turn : %d, value : %d, loss : %f\n" t current_value loss; 67 | main_aux 68 | (total_loss +. loss) 69 | (current_value :: sequence) 70 | (t + 1) 71 | in 72 | main_aux 0. [] 1 73 | 74 | let _ = main negative_log_loss (binomial_generator !m !prob) (binomial_expectator !m) !turn; print_newline () 75 | -------------------------------------------------------------------------------- /matrix/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "main.cmo";; 4 | #use "./test.ml";; -------------------------------------------------------------------------------- /matrix/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCamlProgram($(PROGRAM), $(FILES)) 8 | 9 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 10 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 11 | 12 | .PHONY: clean 13 | clean: 14 | rm -f \ 15 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 16 | $(PROGRAM).run $(PROGRAM).opt 17 | -------------------------------------------------------------------------------- /matrix/README: -------------------------------------------------------------------------------- 1 | ・概要 2 | 行列計算用モジュール.*^,*~,+^,-^はそれぞれ内積,ベクトルの定数倍,ベクトル和,ベクトル差. 3 | 4 | ・SparseMatrix 5 | 圧縮行格納方式による疎行列表現モジュール.今のところ通常の2次元配列から疎行列表現に変換するmake,及びベクトル行列積を行うmut_mul_vecのみの実装だが下のCG法のためにはこれだけで十分である. 6 | 7 | ・cg 8 | 正定値対称行列Aとベクトルb,及び初期値x0に対し共役勾配法(Conjugate Gradient Method)を用いて連立1次方程式を解く.各ループにおいて探索方向を,A共役性をみたす,すなわちAをかけるとこれまでの探索方向に直交するように取る算法を共役方向法と呼び,(誤差のない世界では)Aの次元を越えない回数のループで正しい解を出力することが保証されているが,共役勾配法とはこのうち,kループ目においてこれまでの探索方向の張る空間,及びこれまでの残差の張る空間が,Aによって初期残差r0から生成されるk+1次Krylov部分空間span(r0, A*r0, ..., A^k*r0)に一致するように探索方向をとるものを言う. -------------------------------------------------------------------------------- /matrix/main.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let ( *^ ) x y = 4 | let ans = ref 0. in 5 | for i = 0 to (Array.length x - 1) do 6 | ans := !ans +. x.(i) *. y.(i) 7 | done; 8 | !ans 9 | 10 | let ( *~ ) a x = 11 | Array.map (( *. ) a) x 12 | 13 | let ( +^ ) x y = 14 | let n = Array.length x in 15 | let ans = Array.make n 0. in 16 | for i = 0 to (n - 1) do 17 | ans.(i) <- x.(i) +. y.(i) 18 | done; 19 | ans 20 | 21 | let ( -^ ) x y = 22 | let n = Array.length x in 23 | let ans = Array.make n 0. in 24 | for i = 0 to (n - 1) do 25 | ans.(i) <- x.(i) -. y.(i) 26 | done; 27 | ans 28 | 29 | let norm x = sqrt(x *^ x) 30 | 31 | module SparseMatrix = struct 32 | type t = float array * int array * int array 33 | let make mat = 34 | let m = Array.length mat 35 | and n = Array.length mat.(0) in 36 | let rec extract i j num row col = 37 | if j < 0 then extract (i - 1) (n - 1) num row col 38 | else if i < 0 then (num, row, col) 39 | else if mat.(i).(j) = 0. then extract i (j - 1) num row col 40 | else extract i (j - 1) (mat.(i).(j) :: num) (i :: row) (j :: col) 41 | and shorten row = 42 | let srow = Array.make m 0 in 43 | let rec aux pred i = function 44 | [] -> 45 | Array.to_list srow 46 | | hd :: tl -> 47 | if hd = pred then aux hd (i + 1) tl 48 | else (srow.(hd) <- i; aux hd (i + 1) tl) 49 | in 50 | aux (-1) 0 row 51 | in 52 | let (num, row, col) = extract (m - 1) (n - 1) [] [] [] in 53 | (num, shorten row, col) 54 | let mut_mul_vec (num, row, col) vec = 55 | let m = List.length row 56 | and elm_num = List.length num in 57 | let ans = Array.make m 0. in 58 | let rec mul i num row col = 59 | let rec add i k num col = 60 | if k = 0 then 61 | (num, col) 62 | else 63 | (ans.(i) <- ans.(i) +. (List.hd num) *. vec.(List.hd col); 64 | add i (k - 1) (List.tl num) (List.tl col)) 65 | in 66 | match row with 67 | [] -> ans 68 | | [last] -> 69 | let (num, col) = add i (elm_num - last) num col in 70 | mul (i + 1) num [] col 71 | | hd :: tl -> 72 | let (num, col) = add i (List.hd tl - hd) num col in 73 | mul (i + 1) num tl col 74 | in 75 | mul 0 num row col 76 | let cg a b x0 = 77 | let rec aux x p r = 78 | if norm r < 1e-9 *. norm b then x 79 | else 80 | let ap = mut_mul_vec a p in 81 | let alpha = (r *^ p) /. (p *^ ap) in 82 | let x = x +^ alpha *~ p in 83 | let r = r -^ alpha *~ ap in 84 | let beta = (-1.) *. (r *^ ap) /. (p *^ ap) in 85 | let p = r +^ beta *~ p in 86 | aux x p r 87 | and r0 = b -^ mut_mul_vec a x0 in 88 | aux x0 r0 r0 89 | end 90 | -------------------------------------------------------------------------------- /matrix/test.ml: -------------------------------------------------------------------------------- 1 | open Main 2 | 3 | let a = SparseMatrix.make [| 4 | [|6.;4.;1.|]; 5 | [|4.;5.;0.|]; 6 | [|1.;0.;1.|]|] 7 | 8 | let x = [|1.;1.;1.|] 9 | 10 | let b = SparseMatrix.mut_mul_vec a x 11 | 12 | let x' = SparseMatrix.cg a b [|0.;0.;0.|] 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /polynomialRing/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #directory "../rational";; 3 | #load "../util/utils.cma";; 4 | #load "nums.cma";; 5 | #load "../rational/rationalBig.cmo";; 6 | #load "polynomialRing.cmo";; 7 | #use "./polynomialRing_test.ml";; -------------------------------------------------------------------------------- /polynomialRing/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | ../rational/rationalBig 5 | polynomialRing 6 | polynomialRing_test 7 | 8 | OCAMLINCLUDES += ../rational 9 | OCAML_LIBS[] += 10 | OCAML_OTHER_LIBS[] += nums 11 | 12 | OCamlProgram($(PROGRAM), $(FILES)) 13 | 14 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 15 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 16 | 17 | .PHONY: clean 18 | clean: 19 | rm -f \ 20 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 21 | $(PROGRAM).run $(PROGRAM).opt 22 | -------------------------------------------------------------------------------- /polynomialRing/polynomialRing.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type Field = sig 4 | type t 5 | val ( +^ ) : t -> t -> t 6 | val ( -^ ) : t -> t -> t 7 | val ( *^ ) : t -> t -> t 8 | val ( /^ ) : t -> t -> t 9 | val ( =^ ) : t -> t -> bool 10 | val zero : t 11 | val one : t 12 | val negative : t -> t 13 | val inverse : t -> t 14 | val to_string : t -> string 15 | end 16 | 17 | module Make (F : Field) : sig 18 | type mono = int array 19 | type term = F.t * mono 20 | type var_order = int list 21 | type mono_order = mono -> mono -> int 22 | type poly = term list 23 | val clean : poly -> poly 24 | val degree : mono -> int 25 | val total_degree : poly -> int 26 | val lterm : mono_order -> poly -> term 27 | val is_divider : mono -> mono -> bool 28 | val is_lterm_divider : mono_order -> poly -> poly -> bool 29 | val lex : var_order -> mono_order 30 | val grlex : var_order -> mono_order 31 | val grevlex : var_order -> mono_order 32 | val order_auto : (var_order -> mono_order) -> mono -> mono -> int 33 | val ( +: ) : term -> poly -> poly 34 | val ( +~ ) : poly -> poly -> poly 35 | val ( -~ ) : poly -> poly -> poly 36 | val ( *~ ) : poly -> poly -> poly 37 | val divide : mono_order -> poly list -> poly -> poly list * poly 38 | val ( =~ ) : poly -> poly -> bool 39 | val mult_const_poly : poly -> F.t -> poly 40 | val divide_term : term -> term -> term 41 | val to_string : poly -> string 42 | end = struct 43 | type mono = int array 44 | type term = F.t * mono 45 | type var_order = int list 46 | type mono_order = mono -> mono -> int 47 | type poly = term list 48 | let ( +^ ) = F.( +^ ) 49 | let ( -^ ) = F.( -^ ) 50 | let ( /^ ) = F.( /^ ) 51 | let ( *^ ) = F.( *^ ) 52 | let ( =^ ) = F.( =^ ) 53 | let degree x = Array.fold_left (+) 0 x 54 | let total_degree f = 55 | let deg (a, x) = if a =^ F.zero then 0 else degree x in 56 | List.find_max_val deg f 57 | let lterm mo f = List.find_min ~comp:mo snd f 58 | let is_divider x y = Array.for_all2 (<=) x y 59 | let is_lterm_divider mo g f = is_divider (lterm mo g |> snd) (lterm mo f |> snd) 60 | let rec lex vo x y = 61 | match vo with 62 | [] -> 0 63 | | hd :: tl -> 64 | let diff = x.(hd) - y.(hd) in 65 | if diff > 0 then -1 66 | else if diff < 0 then 1 67 | else lex tl x y 68 | let grlex vo x y = 69 | let ddiff = degree x - degree y in 70 | if ddiff > 0 then -1 71 | else if ddiff < 0 then 1 72 | else lex vo x y 73 | let grevlex vo x y = 74 | let ddiff = degree x - degree y in 75 | if ddiff > 0 then -1 76 | else if ddiff < 0 then 1 77 | else lex (List.rev vo) y x 78 | let order_auto lex x y = 79 | lex (List.range 0 (Array.length x - 1) 1) x y 80 | let clean = List.filter (fun (a, _) -> not (a =^ F.zero)) 81 | let ( +~ ) f g = 82 | let order = order_auto lex in 83 | let order_term (_, x) (_, y) = order x y in 84 | let rec aux f g accum = 85 | match f, g with 86 | [], g -> g @ accum 87 | | f, [] -> f @ accum 88 | | ((fa, fx) as fhd) :: ftl, ((ga, gx) as ghd) :: gtl -> 89 | if order fx gx < 0 then 90 | aux ftl g (fhd :: accum) 91 | else if order fx gx > 0 then 92 | aux f gtl (ghd :: accum) 93 | else 94 | aux ftl gtl ((fa +^ ga, fx) :: accum) 95 | in 96 | aux (List.sort order_term f) (List.sort order_term g) [] |> clean 97 | let ( +: ) t f = [t] +~ f 98 | let mult_const_poly f a = 99 | List.map (fun (b, x) -> a *^ b, x) f |> clean 100 | let mult_term_poly (a, x) f = 101 | List.map (fun (b, y) -> (a *^ b, Array.map2 (+) x y)) f |> clean 102 | let ( -~ ) f g = f +~ mult_const_poly g (F.negative F.one) 103 | let ( *~ ) f g = 104 | List.map (fun t -> mult_term_poly t g) f |> List.fold_left ( +~ ) [] 105 | let ( =~ ) f g = (f -~ g) = [] 106 | let divide_term (a, x) (b, y) = 107 | (a /^ b, Array.map2 (-) x y) 108 | let var_to_string num_total_vars num_var = 109 | if num_total_vars <= 3 then [|"x";"y";"z"|].(num_var) 110 | else [|"z";"y";"x";"w";"v";"u";"t";"s";"r";"q";"p"|].(num_total_vars - num_var - 1) 111 | let term_to_string (a, x) = 112 | let num_total_vars = Array.length x in 113 | let powered_var_to_string i v = 114 | if v = 0 then "" (* const *) 115 | else if v = 1 then var_to_string num_total_vars i 116 | else var_to_string num_total_vars i ^ "^" ^ string_of_int v (* v-th power *) 117 | in 118 | let vars = Array.fold_left (^) "" (Array.mapi powered_var_to_string x) in 119 | F.to_string a ^ (if vars = "" then "" else " * ") ^ vars 120 | let to_string = function 121 | [] -> "0" (* zero polynomial *) 122 | | [hd] -> term_to_string hd (* single term polynomial *) 123 | | hd :: tl -> 124 | List.fold_left (fun t1 t2 -> t1^" + "^t2) (term_to_string hd) (List.map term_to_string tl) 125 | let divide mo gs f = (* monomial order, divisors, dividend respectively *) 126 | let sort = List.sort (fun (_, x) (_, y) -> mo x y) in 127 | let gs, f = List.map sort gs, sort f in 128 | let rec aux qs r r_inter = 129 | (* Printf.printf "r_inter : %s\n" (to_string r_inter); 130 | Printf.printf "r : %s\n" (to_string r); *) 131 | match r_inter with 132 | [] -> List.map clean qs, clean r 133 | | r_inter_hd :: r_inter_tl -> 134 | let r_inter = sort r_inter in 135 | let rec find_dividable qs gs qaccum = 136 | match qs, gs with 137 | [], [] -> raise Not_found 138 | | [], _ | _, [] -> failwith "PolynomialRing.divide : quotient or divisor is missing." 139 | | q :: qtl, g :: gtl -> 140 | if is_lterm_divider mo g r_inter then 141 | let divided = divide_term (lterm mo r_inter) (lterm mo g) in 142 | let new_qs = List.rev qaccum @ ((divided +: q) :: qtl) in 143 | let r_inter = r_inter -~ mult_term_poly divided g in 144 | (* Printf.printf "divider : %s\ndivided : %s\nr_inter' : %s\n\n" (to_string g) (term_to_string divided) (to_string r_inter); *) 145 | (new_qs, r_inter) 146 | else find_dividable qtl gtl (q :: qaccum) 147 | in 148 | try 149 | let (qs, r_inter) = find_dividable qs gs [] in 150 | aux qs r r_inter 151 | with 152 | Not_found -> aux qs (List.hd r_inter +: r) (List.tl r_inter) 153 | in aux (List.map (fun _ -> []) gs) [] f 154 | end 155 | -------------------------------------------------------------------------------- /polynomialRing/polynomialRing_test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | module P = PolynomialRing.Make (RationalBig) 3 | open RationalBig 4 | open P 5 | 6 | let f = [one, [|2; 1|]; one, [|1; 2|]; one, [|0; 2|]] (* x^2y + xy^2 + y^2 *) 7 | let negone = r (-1, 1) 8 | let g1 = [one, [|0; 2|]; negone, [|0; 0|]] (* y^2 - 1 *) 9 | let g2 = [one, [|1; 1|]; negone, [|0; 0|]] (* xy - 1 *) 10 | 11 | let remove_abstr f = List.map (fun (a, x) -> float_of_rational a, x) f 12 | 13 | let divide lex gs f = 14 | let (qs, r) = divide (lex [0;1]) gs f in 15 | (qs, r) 16 | 17 | let sort f = List.sort (fun (_,x) (_,y)-> lex [0;1] x y) f 18 | 19 | let mo = lex [0;1];; 20 | 21 | Random.self_init ();; 22 | 23 | let rand_rational n = RationalBig.rational_of_int (Random.int n + 1) 24 | let num_var = 3 25 | let max_divisor_dim = 2 26 | let max_dividend_dim = 5 27 | let max_num_term = 4 28 | let max_coef = 10 29 | let num_divisors = 3 30 | let rand_poly max_dim : P.poly = 31 | let term () = 32 | (rand_rational max_coef, Array.init num_var (fun i -> Random.int max_dim)) 33 | in 34 | let rec aux n accum = 35 | if n <= 0 then accum 36 | else aux (n - 1) (term () +: accum) 37 | in 38 | aux (Random.int max_num_term + 1) [] |> clean 39 | let divisors () = List.init (fun i -> rand_poly max_divisor_dim) num_divisors 40 | let dividend () = rand_poly max_dividend_dim 41 | let test () = 42 | let s = to_string in let m = List.map to_string in 43 | let f = List.fold_left (fun s t -> s^"\n"^t) "" in 44 | let divisors = divisors () 45 | and dividend = dividend () in 46 | let (qs, r) = divide lex divisors dividend in 47 | Printf.printf "divisors : %s\ndividend : %s\n" (m divisors |> f) (s dividend); 48 | Printf.printf "qs : %s\nr : %s\n" (m qs |> f) (s r) (* List.fold_left ( +~ ) [] (List.map2 ( *~ ) qs divisors) +~ r *); 49 | (List.map2 ( *~ ) qs divisors |> List.fold_left (+~) []) +~ r =~ dividend 50 | 51 | let rec iter n = 52 | if n <= 0 then () 53 | else begin 54 | if test () then iter (n - 1) 55 | else failwith "false" 56 | end 57 | 58 | let _ = iter (int_of_string Sys.argv.(1)) 59 | 60 | -------------------------------------------------------------------------------- /rational/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "nums.cma";; 4 | #load "rational.cmo";; 5 | #load "rationalBig.cmo";; 6 | #use "./rational_test.ml";; -------------------------------------------------------------------------------- /rational/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | rational 5 | rationalBig 6 | rational_test 7 | 8 | OCAML_OTHER_LIBS += nums 9 | 10 | OCamlProgram($(PROGRAM), $(FILES)) 11 | 12 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 13 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 14 | 15 | .PHONY: clean 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 19 | $(PROGRAM).run $(PROGRAM).opt 20 | -------------------------------------------------------------------------------- /rational/README: -------------------------------------------------------------------------------- 1 | 多項式環モジュール用に書いた,(分子,分母)の組により有理数を表現するモジュール.何らかの操作のたび最大公約数を計算(O(logN))して約分を行うようにしてあるが,int版の場合あっさりオーバーフローするかも知れない. -------------------------------------------------------------------------------- /rational/rational.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = int * int (* p /. q. q must be positive. *) 4 | 5 | let gcd m n = 6 | let abs k = if k >= 0 then k else -k in 7 | let rec aux m n = 8 | if n = 0 then m 9 | else aux n (m mod n) 10 | in 11 | aux (abs m) (abs n) 12 | 13 | let normalize (p, q) = 14 | let (p, q) = if q < 0 then (-p, -q) else if q > 0 then (p, q) else raise Division_by_zero in 15 | let d = gcd p q in 16 | (p / d, q / d) 17 | 18 | let r = normalize 19 | 20 | let ( +^ ) (ap, aq) (bp, bq) = normalize (ap * bq + bp * aq, aq * bq) 21 | let ( -^ ) (ap, aq) (bp, bq) = normalize (ap * bq - bp * aq, aq * bq) 22 | let ( *^ ) (ap, aq) (bp, bq) = normalize (ap * bp, aq * bq) 23 | let ( /^ ) (ap, aq) (bp, bq) = normalize (ap * bq, bp * aq) 24 | let ( >^ ) (ap, aq) (bp, bq) = ap * bq > bp * aq 25 | let ( >=^ ) a b = not (b >^ a) 26 | let ( <^ ) a b = b >^ a 27 | let ( <=^ ) a b = not (a >^ b) 28 | let ( =^ ) a b = a >=^ b && a <=^ b 29 | let ( <>^ ) a b = a <^ b || a >^ b 30 | let one = (1, 1) 31 | let zero = (0, 1) 32 | let negative (p, q) = (-p, q) 33 | let inverse (p, q) = if p < 0 then (-q, -p) else (q, p) 34 | let float_of_rational (p, q) = 35 | if q = 0 then failwith "Division_by_zero at rational" 36 | else float p /. float q 37 | let rational_of_int i = (i, 1) 38 | let to_string r = float_of_rational r |> string_of_float 39 | -------------------------------------------------------------------------------- /rational/rational.mli: -------------------------------------------------------------------------------- 1 | type t 2 | val r : int * int -> t 3 | val ( +^ ) : t -> t -> t 4 | val ( -^ ) : t -> t -> t 5 | val ( *^ ) : t -> t -> t 6 | val ( /^ ) : t -> t -> t 7 | val ( >^ ) : t -> t -> bool 8 | val ( >=^ ) : t -> t -> bool 9 | val ( <^ ) : t -> t -> bool 10 | val ( <=^ ) : t -> t -> bool 11 | val ( =^ ) : t -> t -> bool 12 | val ( <>^ ) : t -> t -> bool 13 | val one : t 14 | val zero : t 15 | val negative : t -> t 16 | val inverse : t -> t 17 | val float_of_rational : t -> float 18 | val rational_of_int : int -> t 19 | val to_string : t -> string 20 | -------------------------------------------------------------------------------- /rational/rationalBig.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Big_int 3 | 4 | type t = big_int * big_int (* p /. q. q must be positive. *) 5 | 6 | let is_zero i = sign_big_int i = 0 7 | 8 | let gcd m n = 9 | let rec aux m n = 10 | if is_zero n then m 11 | else aux n (mod_big_int m n) 12 | in 13 | aux (abs_big_int m) (abs_big_int n) 14 | 15 | let normalize (p, q) = 16 | if is_zero q && not (is_zero p) then failwith "aaa" 17 | else if is_zero q then failwith "bbb"; 18 | let (p, q) = 19 | if sign_big_int q < 0 then 20 | (minus_big_int p, minus_big_int q) 21 | else if sign_big_int q > 0 then 22 | (p, q) 23 | else raise Division_by_zero 24 | in 25 | let d = gcd p q in 26 | (div_big_int p d, div_big_int q d) 27 | 28 | let r (p, q) = normalize (big_int_of_int p, big_int_of_int q) 29 | 30 | let ( + ) = add_big_int 31 | let ( * ) = mult_big_int 32 | let ( - ) = sub_big_int 33 | let ( +^ ) (ap, aq) (bp, bq) = 34 | if is_zero aq || is_zero bq then failwith "ccc" 35 | else if is_zero (aq * bq) then failwith "ddd"; 36 | normalize (ap * bq + bp * aq, aq * bq) 37 | let ( -^ ) (ap, aq) (bp, bq) = normalize (ap * bq - bp * aq, aq * bq) 38 | let ( *^ ) (ap, aq) (bp, bq) = normalize (ap * bp, aq * bq) 39 | let ( /^ ) (ap, aq) (bp, bq) = normalize (ap * bq, bp * aq) 40 | let ( >^ ) (ap, aq) (bp, bq) = gt_big_int (ap * bq) (bp * aq) 41 | let ( >=^ ) a b = not (b >^ a) 42 | let ( <^ ) a b = b >^ a 43 | let ( <=^ ) a b = not (a >^ b) 44 | let ( =^ ) a b = a >=^ b && a <=^ b 45 | let ( <>^ ) a b = a <^ b || a >^ b 46 | let one = (big_int_of_int 1, big_int_of_int 1) 47 | let zero = (big_int_of_int 0, big_int_of_int 1) 48 | let negative (p, q) = (minus_big_int p, q) 49 | let inverse (p, q) = if sign_big_int p < 0 then (minus_big_int q, minus_big_int p) else (q, p) 50 | let float_of_rational (p, q) = 51 | if is_zero q then failwith "Division_by_zero at rational" 52 | else float_of_big_int p /. float_of_big_int q 53 | let rational_of_int i = (big_int_of_int i, big_int_of_int 1) 54 | let to_string (p, q) = 55 | let (sp, sq) = string_of_big_int p, string_of_big_int q in 56 | if eq_big_int q unit_big_int then sp 57 | else "(" ^ sp ^ " / " ^ sq ^ ")" 58 | -------------------------------------------------------------------------------- /rational/rationalBig.mli: -------------------------------------------------------------------------------- 1 | type t 2 | val r : int * int -> t 3 | val ( +^ ) : t -> t -> t 4 | val ( -^ ) : t -> t -> t 5 | val ( *^ ) : t -> t -> t 6 | val ( /^ ) : t -> t -> t 7 | val ( >^ ) : t -> t -> bool 8 | val ( >=^ ) : t -> t -> bool 9 | val ( <^ ) : t -> t -> bool 10 | val ( <=^ ) : t -> t -> bool 11 | val ( =^ ) : t -> t -> bool 12 | val ( <>^ ) : t -> t -> bool 13 | val one : t 14 | val zero : t 15 | val negative : t -> t 16 | val inverse : t -> t 17 | val float_of_rational : t -> float 18 | val rational_of_int : int -> t 19 | val to_string : t -> string 20 | -------------------------------------------------------------------------------- /rational/rational_test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open RationalBig 3 | 4 | let x = r (1, 2) -^ r (1, 6) 5 | let y = r (-1, -4) 6 | -------------------------------------------------------------------------------- /sort/.ocamlinit: -------------------------------------------------------------------------------- 1 | #load "unix.cma";; 2 | #directory "../util";; 3 | #load "../util/utils.cma";; 4 | #load "main.cmo";; 5 | #use "./test.ml";; 6 | -------------------------------------------------------------------------------- /sort/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | test 6 | 7 | OCAMLPACKS[] = unix 8 | 9 | OCamlProgram($(PROGRAM), $(FILES)) 10 | 11 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 12 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 13 | 14 | .PHONY: clean 15 | clean: 16 | rm -f \ 17 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 18 | $(PROGRAM).run $(PROGRAM).opt 19 | -------------------------------------------------------------------------------- /sort/main.ml: -------------------------------------------------------------------------------- 1 | open Util;; 2 | 3 | Random.self_init () 4 | 5 | let insertsort comp xs = 6 | let rec target pos value xs = 7 | if pos = 0 then 0 8 | else if comp xs.(pos - 1) value <= 0 then pos 9 | else target (pos - 1) value xs 10 | in 11 | for pos = 1 to Array.length xs - 1 do 12 | let value = xs.(pos) in 13 | let t = target pos value xs in 14 | Array.blit xs t xs (t + 1) (pos - t); 15 | xs.(t) <- value 16 | done 17 | 18 | let quicksort comp xs = 19 | let n = Array.length xs in 20 | let rec quicksort_aux xs s e = 21 | if s >= e - 1 then 22 | () 23 | else 24 | let rec move_by_swap comp pivot s e xs = 25 | try 26 | let i = Array.find_num_left ~start:s (fun x -> comp pivot x <= 0) xs 27 | and j = Array.find_num_right ~start:(n - e) (fun x -> comp pivot x > 0) xs 28 | in 29 | if i = j then 30 | failwith "There are bug(s) in Util.Array.find_num_* " 31 | else if i < j then begin 32 | Array.swap i j xs; 33 | move_by_swap comp pivot i j xs 34 | end 35 | else 36 | i 37 | with 38 | Not_found -> s 39 | in 40 | let select_pivot xs s e = xs.(Random.int (e - s) + s) in 41 | let pivot = select_pivot xs s e in 42 | let i = move_by_swap comp pivot s e xs in 43 | quicksort_aux xs s i; 44 | quicksort_aux xs i e 45 | in 46 | quicksort_aux xs 0 n 47 | 48 | -------------------------------------------------------------------------------- /sort/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Unix 3 | 4 | type order = Sorted | Almost_sorted | Random | Reverse 5 | type element = Integer | List 6 | type sorter = Quicksort | Insertsort 7 | 8 | let size = ref 1 9 | let order = ref Random 10 | let element = ref Integer 11 | let sorter = ref Quicksort 12 | 13 | let string_to_order = function 14 | "sorted" -> Sorted 15 | | "almost" -> Almost_sorted 16 | | "random" -> Random 17 | | "reverse" -> Reverse 18 | | _ -> failwith "Invalid type of order" 19 | let string_to_element = function 20 | "int" -> Integer 21 | | "list" -> List 22 | | _ -> failwith "Invalid type of elements" 23 | let string_to_sorter = function 24 | "quick" -> Quicksort 25 | | "insert" -> Insertsort 26 | | _ -> failwith "Invalid name of sort function" 27 | 28 | let speclist = [ 29 | ("-s", Arg.Set_int size, ""); 30 | ("-t", Arg.String (fun s -> order := string_to_order s), ""); 31 | ("-e", Arg.String (fun s -> element := string_to_element s), ""); 32 | ("-a", Arg.String (fun s -> sorter := string_to_sorter s), ""); 33 | ];; 34 | 35 | let select_order order xs = 36 | let n = Array.length xs in match order with 37 | Sorted -> xs 38 | | Almost_sorted -> 39 | let rec perturb accum xs = 40 | let hd = List.hd xs and tl = List.tl xs in 41 | if List.length xs <= 4 then List.rev accum @ xs 42 | else if Random.int 4 = 0 then 43 | let modify = List.map (fun x -> if hd < x && x <= hd + 4 then x - 1 else x) in 44 | perturb (hd + 4 :: modify accum) (modify tl) 45 | else 46 | perturb (hd :: accum) tl 47 | in 48 | Array.permutate (List.range 0 (n - 1) 1 |> perturb []) xs 49 | | Random -> Array.permutate (List.random_permutation n) xs 50 | | Reverse -> Array.permutate (List.range (n - 1) 0 (-1)) xs 51 | 52 | let select_sort = function 53 | Quicksort -> Main.quicksort 54 | | Insertsort -> Main.insertsort 55 | 56 | let check sorter order comp m = 57 | let a = select_order order (Array.init m identity) in 58 | let b = Array.copy a in 59 | Array.sort comp a = sorter comp b 60 | 61 | let _ = 62 | Random.self_init (); 63 | Arg.parse speclist (fun s -> ()) ""; 64 | let f () = match !element with 65 | Integer -> 66 | let elm n = n 67 | and cmp = Pervasives.compare in 68 | (select_sort !sorter) cmp (select_order !order (Array.init !size elm)); () 69 | | List -> 70 | let elm n = List.make 9 0 @ [n] 71 | and cmp xs ys = Pervasives.compare (List.last xs) (List.last ys) in 72 | (select_sort !sorter) cmp (select_order !order (Array.init !size elm)); () 73 | in 74 | Util.time Unix.gettimeofday 1 f () |> Printf.printf "%e\n" 75 | -------------------------------------------------------------------------------- /string/.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind" 2 | #require "unix" 3 | #directory "../util";; 4 | #load "util.cma";; 5 | #load "fpiSummerIntern2011Quiz.cmo" 6 | #load "suffixArray.cmo" 7 | #use "./test.ml" 8 | -------------------------------------------------------------------------------- /string/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | fpiSummerIntern2011Quiz 5 | suffixArray 6 | test 7 | 8 | OCAML_OTHER_LIBS += unix 9 | 10 | OCamlProgram($(PROGRAM), $(FILES)) 11 | 12 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 13 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 14 | 15 | .PHONY: clean 16 | clean: 17 | rm -f \ 18 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 19 | $(PROGRAM).run $(PROGRAM).opt 20 | -------------------------------------------------------------------------------- /string/fpiSummerIntern2011Quiz.ml: -------------------------------------------------------------------------------- 1 | let debug = false 2 | 3 | let find_freq x = 4 | let open String in 5 | let rec aux x len remain = 6 | if debug then Printf.printf "%s, %d, %c\n" (sub x 0 len) len remain; 7 | match len with 8 | | 1 -> get x 0 9 | | 0 -> remain 10 | | _ -> 11 | let rec pair i len_next = 12 | if i = len / 2 then (* problem size halved *) 13 | (len_next, if len land 1 = 1 then get x (len - 1) else remain) 14 | else match get x (2 * i) with 15 | c when c = get x (2 * i + 1) -> 16 | set x len_next c; (* constant time operation *) 17 | pair (i + 1) (len_next + 1) 18 | | _ -> 19 | pair (i + 1) len_next 20 | in 21 | let (len_next, remain_next) = pair 0 0 in 22 | aux x len_next remain_next 23 | in 24 | aux (copy x) (length x) ' ';; 25 | -------------------------------------------------------------------------------- /string/suffixArray.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | let tripartition compare pivot xs = 4 | let len = Array.length xs in 5 | let rec aux l m r n is_l_turn = 6 | if l > r then (* finished *) 7 | ( 8 | Array.sub xs m (r - m + 1), 9 | Array.append (Array.sub xs 0 m) (Array.sub xs (n + 1) (len - n - 1)), 10 | Array.sub xs l (n - r) 11 | ) 12 | else if is_l_turn then (* step from left side *) 13 | let c = compare pivot xs.(l) in 14 | if c = 0 then 15 | (Array.swap l m xs; aux (l + 1) (m + 1) r n false) 16 | else if c < 0 then 17 | if compare pivot xs.(r) > 0 then (Array.swap l r xs; aux (l + 1) m (r - 1) n false) 18 | else aux l m r n false 19 | else 20 | aux (l + 1) m r n false 21 | else (* step from right side *) 22 | let c = compare pivot xs.(r) in 23 | if c = 0 then 24 | (Array.swap r n xs; aux l m (r - 1) (n - 1) true) 25 | else if c > 0 then 26 | if compare pivot xs.(l) < 0 then (Array.swap r l xs; aux (l + 1) m (r - 1) n true) 27 | else aux l m r n true 28 | else 29 | aux l m (r - 1) n true 30 | in 31 | aux 0 0 (len - 1) (len - 1) true;; 32 | 33 | type sign = Pos | Zero | Neg 34 | let sign i = if i > 0 then Pos else if i = 0 then Zero else Neg 35 | 36 | let rec ternary_sort cmp xs = 37 | let len = Array.length xs in 38 | match len with 39 | 0 -> [] 40 | | 1 -> [xs] 41 | | 2 -> ( 42 | let a, b = xs.(0), xs.(1) in match cmp a b |> sign with 43 | Pos -> [[|b|];[|a|]] 44 | | Zero -> [[|a;b|]] 45 | | Neg -> [[|a|];[|b|]] 46 | ) 47 | | 3 -> ( 48 | let a, b, c = xs.(0), xs.(1), xs.(2) in 49 | match sign (cmp a b) with 50 | Pos -> begin match sign (cmp b c) with 51 | Pos -> [[|c|];[|b|];[|a|]] 52 | | Zero -> [[|b;c|];[|a|]] 53 | | Neg -> begin match sign (cmp a c) with 54 | | Pos -> [[|b|];[|c|];[|a|]] 55 | | Zero -> [[|b|];[|a;c|]] 56 | | Neg -> [[|b|];[|a|];[|c|]] end end 57 | | Zero -> begin match sign (cmp b c) with 58 | | Pos -> [[|c|];[|a;b|]] 59 | | Zero -> [[|a;b;c|]] 60 | | Neg -> [[|a;b|];[|c|]] end 61 | | Neg -> begin match sign (cmp b c) with 62 | Pos -> begin match sign (cmp a c) with 63 | | Pos -> [[|c|];[|a|];[|b|]] 64 | | Zero -> [[|a;c|];[|b|]] 65 | | Neg -> [[|a|];[|c|];[|b|]] end 66 | | Zero -> [[|a|];[|b;c|]] 67 | | Neg -> [[|a|];[|b|];[|c|]] end 68 | ) 69 | | _ -> 70 | let select_pivot xs = (* len supposed to be larger than 3 *) 71 | let a = xs.(len / 4) 72 | and b = xs.(len / 2) 73 | and c = xs.(len - len / 4) 74 | in 75 | if cmp a b >= 0 then 76 | if cmp c a >= 0 then a 77 | else if cmp b c >= 0 then b 78 | else c 79 | else 80 | if cmp c b >= 0 then b 81 | else if cmp a c >= 0 then a 82 | else c 83 | in 84 | let l, c, r = tripartition cmp (select_pivot xs) xs in 85 | ternary_sort cmp l @ [c] @ ternary_sort cmp r 86 | 87 | let sort_0 str = (* initialization. make 1-ordered suffix array *) 88 | let str = str ^ "\n" in 89 | let length = String.length str in 90 | let compare i j = compare str.[i] str.[j] 91 | and suffix = Array.init length identity 92 | and group = Array.make length (length - 1) 93 | and skip = Array.make length 0 94 | in 95 | (* make init suffix *) 96 | Array.stable_sort compare suffix; 97 | (* make init group *) 98 | for i = length - 2 downto 0 do 99 | if compare suffix.(i) suffix.(i + 1) = 0 then 100 | group.(suffix.(i)) <- group.(suffix.(i + 1)) 101 | else 102 | group.(suffix.(i)) <- i 103 | done; 104 | (* make init skip *) 105 | let cont = ref 0 in 106 | for i = length - 1 downto 1 do 107 | if group.(suffix.(i)) != group.(suffix.(i - 1)) then begin 108 | if !cont = 0 then skip.(suffix.(i)) <- -1 109 | else skip.(suffix.(i)) <- !cont + 1; 110 | cont := 0 end 111 | else 112 | incr cont 113 | done; 114 | skip.(suffix.(0)) <- -1; 115 | suffix, group, skip;; 116 | 117 | let sort_h h start len (suffix, group, skip) = (* make 2h-ordered suffix array using that is h-ordered *) 118 | let cmp i j = compare group.(i + h) group.(j + h) in 119 | let sorted = ternary_sort cmp (Array.sub suffix start len) in 120 | let rec apply n sorted = match sorted with 121 | [] -> 122 | () 123 | | hd :: tl -> 124 | let l = Array.length hd in 125 | Array.blit hd 0 suffix (start + n) l; (* update suffix *) 126 | Array.iter (fun i -> group.(i) <- group.(i) - len + n + l) hd; (* update group *) 127 | let _ = match hd with (* update skip *) 128 | [||] -> failwith "sort_h" 129 | | [|i|] -> skip.(i) <- -1 130 | | _ -> skip.(hd.(0)) <- Array.length hd 131 | in 132 | apply (n + l) tl 133 | in 134 | apply 0 sorted;; 135 | 136 | let sort (suffix, group, skip) = (* sort recursively starting from 1-ordered suffix array *) 137 | let len = Array.length suffix in 138 | let rec aux_out h = (* loop on h *) 139 | if h > len then (* finished *) 140 | suffix 141 | else 142 | let rec aux_in n = (* loop in some h *) 143 | if n >= len then () 144 | else 145 | let s = skip.(suffix.(n)) in match sign s with 146 | Pos -> sort_h h n s (suffix, group, skip); aux_in (n + s) 147 | | Zero -> failwith "sort" 148 | | Neg -> aux_in (n - s) 149 | in 150 | aux_in 0; 151 | aux_out (h * 2) 152 | in 153 | aux_out 1;; 154 | 155 | let make_suffix_array str = sort (sort_0 str);; 156 | 157 | 158 | 159 | 160 | 161 | 162 | -------------------------------------------------------------------------------- /string/suffixArray.mli: -------------------------------------------------------------------------------- 1 | val make_suffix_array : string -> int array 2 | -------------------------------------------------------------------------------- /string/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | (* fpiSummerIntern2011Quiz *) 4 | (* 5 | let x1 = "aabbababa" 6 | let x2 = "aabbaabbaabbaabbccddaaabbabaababaaaaabaa" 7 | let x3 = "baabbaa" 8 | let x4 = "abcaabaca" 9 | let x5 = "abcaabaac" 10 | let xs = [x1; x2; x3; x4; x5] 11 | 12 | let _ = List.iter (fun x -> Printf.printf "problem : %s, ans : %c\n" x (FpiSummerIntern2011Quiz.find_freq x)) xs 13 | *) 14 | 15 | (* suffixArray *) 16 | 17 | let make_string f m n = 18 | let x = String.create n in 19 | List.iter (fun i -> x.[i] <- Char.chr(f i)) (List.init identity n); 20 | x 21 | 22 | let random_string m n = 23 | let f i = Random.int m + 33 in 24 | make_string f m n 25 | 26 | let u1 m n = 27 | let f i = i mod m + 33 in 28 | make_string f m n 29 | 30 | let u2 m n = 31 | let f i = i / (n / m) + 33 in 32 | make_string f m n 33 | 34 | let read i = int_of_string Sys.argv.(i) 35 | 36 | let _ = 37 | let s = match Sys.argv.(1) with 38 | "-s" -> String.sub (read_line ()) 0 (read 2) (* stdin *) 39 | | "-r" -> random_string (read 2) (read 3) 40 | | "-u1" -> u1 (read 2) (read 3) 41 | | "-u2" -> u2 (read 2) (read 3) 42 | | _ -> failwith "invalid input" 43 | in 44 | time Unix.gettimeofday 1 45 | (fun s -> SuffixArray.make_suffix_array s |> Array.iter (Printf.printf "%d ")) 46 | s 47 | |> Printf.printf "\ntime : %f[s]\n" 48 | -------------------------------------------------------------------------------- /timer_test/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "unix.cma";; 3 | #load "../util/utils.cma";; 4 | #use "main.ml";; -------------------------------------------------------------------------------- /timer_test/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | main 5 | 6 | 7 | OCAMLPACKS[] += unix 8 | 9 | OCamlProgram($(PROGRAM), $(FILES)) 10 | 11 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 12 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 13 | 14 | .PHONY: clean 15 | clean: 16 | rm -f \ 17 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 18 | $(PROGRAM).run $(PROGRAM).opt 19 | 20 | -------------------------------------------------------------------------------- /timer_test/README: -------------------------------------------------------------------------------- 1 | 実行速度測定の際,タイマーの解像度を実際に測っておくことは非常に重要である.このプログラムはUtil.gettimeofdayを10000回実行して0より大きい最小の返り値の差を返す. -------------------------------------------------------------------------------- /timer_test/main.ml: -------------------------------------------------------------------------------- 1 | open Unix 2 | open Util 3 | 4 | (** Get resolution of unix timer. *) 5 | let get_tick n = 6 | let rec get_tick_aux i accum = 7 | if i <= 0 then 8 | let tick = List.to_chain accum 9 | |> List.map (fun (a, b) -> a -. b) 10 | |> List.filter ((<) 0.) |> List.find_min identity 11 | and overhead = (List.find_max identity accum -. List.find_min identity accum) /. float n 12 | in 13 | (tick, overhead) 14 | else get_tick_aux (i - 1) (gettimeofday () :: accum) 15 | in 16 | get_tick_aux n [] 17 | 18 | let _ = 19 | let (tick, overhead) = get_tick 10000 in 20 | Printf.printf "Unix timer : resolution is %.2e sec, overhead is %.2e sec.\n" tick overhead;; 21 | -------------------------------------------------------------------------------- /tree/.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "../util";; 2 | #load "../util/utils.cma";; 3 | #load "redBlackTree.cmo";; 4 | #load "splayTree.cmo";; 5 | #use "./test.ml";; 6 | -------------------------------------------------------------------------------- /tree/OMakefile: -------------------------------------------------------------------------------- 1 | PROGRAM = camlprog 2 | 3 | FILES[] = 4 | splayTree 5 | redBlackTree 6 | test 7 | 8 | 9 | OCamlProgram($(PROGRAM), $(FILES)) 10 | 11 | .DEFAULT: $(if $(BYTE_ENABLED), $(PROGRAM).run) \ 12 | $(if $(NATIVE_ENABLED), $(PROGRAM).opt) 13 | 14 | .PHONY: clean 15 | clean: 16 | rm -f \ 17 | $(filter-proper-targets $(glob $(addsuffix .*, $(FILES)))) \ 18 | $(PROGRAM).run $(PROGRAM).opt 19 | -------------------------------------------------------------------------------- /tree/redBlackTree.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type OrderedType = sig 4 | type t 5 | val compare : t -> t -> int 6 | end 7 | 8 | module Make(Ord : OrderedType) : sig 9 | type elt = Ord.t 10 | type t 11 | val empty : t 12 | val find : elt -> t -> elt 13 | val insert : elt -> t -> t 14 | end = 15 | struct 16 | type color = Red | Black 17 | type elt = Ord.t 18 | type t = Nil | Node of color * elt * t * t 19 | 20 | let (=~) x y = Ord.compare x y = 0 21 | let (<~) x y = Ord.compare x y < 0 22 | let (>~) x y = Ord.compare x y > 0 23 | 24 | let empty = Nil 25 | 26 | let rec find x = function 27 | Nil -> raise Not_found 28 | | Node (_, y, _, _) when x =~ y -> y 29 | | Node (_, y, l, _) when x <~ y -> find x l 30 | | Node (_, y, _, r) -> find x r 31 | let rec apply_at f x = function 32 | Nil -> raise Not_found 33 | | Node (_, y, _, _) as n when x =~ y -> f n 34 | | Node (c, y, l, r) when x <~ y -> Node (c, y, apply_at f x l, r) 35 | | Node (c, y, l, r) -> Node (c, y, l, apply_at f x r) 36 | let rot_right = function 37 | Node (c, y, Node(c', z, l', r'), r) -> Node (c', z, l', Node (c, y, r', r)) 38 | | _ -> failwith "rot_right : Nil must be leaf." 39 | let rot_left = function 40 | Node (c, y, l, Node (c', z, l', r')) -> Node (c', z, Node (c, y, l, l'), r') 41 | | _ -> failwith "rot_left : Nil must be leaf." 42 | type position = Left | Right | None 43 | let insert x t = 44 | let double_red = function 45 | Node (Red, _, (Node (Red, _, _, _)), _) -> Left 46 | | Node (Red, _, _, (Node (Red, _, _, _))) -> Right 47 | | _ -> None 48 | and paint c p t = match (p, t) with 49 | (Left, Node (cc, x, Node (_, y, a, b), r)) -> Node (cc, x, Node (c, y, a, b), r) 50 | | (Right, Node (cc, x, l, Node (_, y, a, b))) -> Node (cc, x, l, Node (c, y, a, b)) 51 | | (None, Node (_, x, l, r)) -> Node (c, x, l, r) 52 | | _ -> failwith "paint : attempt to paint Nil." 53 | in 54 | let balance c y l r = 55 | match (double_red l, double_red r) with 56 | (Left, None) -> Node (c, y, l, r) |> rot_right |> paint Black Left 57 | | (Right, None) -> Node (c, y, rot_left l, r) |> rot_right |> paint Black Left 58 | | (None, Left) -> Node (c, y, l, rot_right r) |> rot_left |> paint Black Right 59 | | (None, Right) -> Node (c, y, l, r) |> rot_left |> paint Black Right 60 | | (None, None) -> Node (c, y, l, r) 61 | | _ -> failwith "balance : fatal error." 62 | in 63 | let rec insert_aux x = function 64 | Nil -> Node (Red, x, Nil, Nil) 65 | | Node (_, y, l, r) as n when x =~ y -> n 66 | | Node (c, y, l, r) when x <~ y -> balance c y (insert_aux x l) r 67 | | Node (c, y, l, r) -> balance c y l (insert_aux x r) 68 | in 69 | insert_aux x t |> paint Black None 70 | end 71 | -------------------------------------------------------------------------------- /tree/splayTree.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module type OrderedType = sig 4 | type t 5 | val compare : t -> t -> int 6 | end 7 | 8 | module Make(Ord : OrderedType) : sig 9 | type elt = Ord.t 10 | type t= Nil | Node of elt * t * t 11 | val empty : t 12 | val find : elt -> t -> elt * t 13 | val insert : elt -> t -> t 14 | val print : (elt -> unit) -> t -> unit 15 | end = 16 | struct 17 | type elt = Ord.t 18 | type t = Nil | Node of elt * t * t 19 | 20 | let (=~) x y = Ord.compare x y = 0 21 | let (<~) x y = Ord.compare x y < 0 22 | let (>~) x y = Ord.compare x y > 0 23 | 24 | let empty = Nil 25 | 26 | let rot_right = function 27 | Node (y, Node(z, l', r'), r) -> Node (z, l', Node (y, r', r)) 28 | | _ -> failwith "rot_right : Nil must be leaf." 29 | 30 | let rot_left = function 31 | Node (y, l, Node (z, l', r')) -> Node (z, Node (y, l, l'), r') 32 | | _ -> failwith "rot_left : Nil must be leaf." 33 | 34 | let zig x = function 35 | Node (_, Node(y, _, _), _) as n when x =~ y -> rot_right n 36 | | Node (_, _, Node(y, _, _)) as n when x =~ y -> rot_left n 37 | | _ as n -> n 38 | 39 | let splay x = function 40 | Nil -> raise Not_found 41 | | Node (y, l, r) as a -> 42 | if x =~ y then a 43 | else if x <~ y then match l with 44 | Node (_, Node(z, _, _), _) when x =~ z -> rot_right (rot_right a) (* zig-zig *) 45 | | Node (_, _, Node (z, _, _)) when x =~ z -> rot_right (Node(y, (rot_left l), r)) (* zig-zag *) 46 | | _ -> a 47 | else match r with 48 | Node (_, _, Node (z, _, _)) when x =~ z -> rot_left (rot_left a) 49 | | Node (_, Node(z, _, _), _) when x =~ z -> rot_left (Node(y, l, rot_right r)) 50 | | _ -> a 51 | 52 | let find x t = 53 | let found = ref x in 54 | let rec aux = function 55 | Nil -> raise Not_found 56 | | Node (y, _, _) as n when x =~ y -> found := y; splay x n 57 | | Node (y, l, r) when x <~ y -> Node (y, splay x (aux l), r) 58 | | Node (y, l, r) -> Node (y, l, splay x (aux r)) 59 | in 60 | !found, aux t |> splay x |> zig x 61 | 62 | let insert x t = 63 | let rec aux = function 64 | Nil -> Node (x, Nil, Nil) 65 | | Node (y, _, _) when x =~ y -> raise (Invalid_argument "insert : already exists") 66 | | Node (y, l, r) when x <~ y -> Node (y, splay x (aux l), r) 67 | | Node (y, l, r) -> Node (y, l, splay x (aux r)) 68 | in 69 | aux t |> splay x |> zig x 70 | 71 | let rec height = function 72 | Nil -> 0 73 | | Node (_, l, r) -> max (height l + 1) (height r + 1) 74 | 75 | let print p t = 76 | let elms = Array.make (height t) [] in 77 | let rec aux t h = match t with 78 | Nil -> () 79 | | Node (x, l, r) -> 80 | elms.(h) <- x :: elms.(h); 81 | aux l (h + 1); 82 | aux r (h + 1) 83 | in 84 | aux t 0; 85 | Array.iter (fun l -> List.iter (fun x -> p x; Printf.printf " ") (List.rev l); Printf.printf "\n") elms 86 | end 87 | -------------------------------------------------------------------------------- /tree/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module M = struct 4 | type t = int * string 5 | let compare (m, _) (n, _)= compare m n 6 | end 7 | 8 | module T = SplayTree.Make(M) 9 | 10 | 11 | 12 | let t = T.empty 13 | let t = T.insert (13, "thirteen") t 14 | let t = T.insert (8, "eight") t 15 | let t = T.insert (17, "seventeen") t 16 | let t = T.insert (1, "one") t 17 | let t = T.insert (11, "eleven") t 18 | let t = T.insert (15, "fifteen") t 19 | let t = T.insert (25, "twenty-five") t 20 | -------------------------------------------------------------------------------- /util/.ocamlinit: -------------------------------------------------------------------------------- 1 | #load "unix.cma";; 2 | #load "util.cma";; 3 | #use "test.ml" 4 | -------------------------------------------------------------------------------- /util/OMakefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean install 2 | 3 | FILES[] = 4 | utilPervasives 5 | utilList 6 | utilArray 7 | util 8 | 9 | LIB = util 10 | OCAMLLINK = $(OCAMLC) 11 | OCAMLOPTLINK = $(OCAMLOPT) 12 | NATIVE_ENABLED = true 13 | 14 | .DEFAULT: all 15 | 16 | all: $(OCamlLibrary $(LIB), $(FILES)) 17 | 18 | install: all 19 | ocamlfind install $(LIB) META $(LIB).a $(LIB).cma $(LIB).cmi $(LIB).cmx $(LIB).cmxa 20 | 21 | clean: 22 | rm -rf *.cm[iox] *.o *~ *.omc .omakedb .omakedb.lock *.cmxa *.a *.annot 23 | 24 | 25 | -------------------------------------------------------------------------------- /util/test.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | let f m n = (List.delete_nth m) (List.init identity n);; 3 | let check_delete_nth n trial = time Unix.gettimeofday trial (List.delete_nth (n / 2)) (List.init identity n);; 4 | let check_delete_nth_naive n trial = time Unix.gettimeofday trial (List.delete_nth_naive (n / 2)) (List.init identity n);; 5 | -------------------------------------------------------------------------------- /util/util.ml: -------------------------------------------------------------------------------- 1 | include UtilPervasives 2 | 3 | module List = struct 4 | include List 5 | include UtilList 6 | end 7 | 8 | module Array = struct 9 | include Array 10 | include UtilArray 11 | end 12 | -------------------------------------------------------------------------------- /util/utilArray.ml: -------------------------------------------------------------------------------- 1 | open UtilPervasives 2 | 3 | let print to_string xs = 4 | Array.iter (fun x -> Printf.printf "%s " (to_string x)) xs; 5 | Printf.printf "\n" 6 | 7 | let mapi f = function 8 | [||] -> [||] 9 | | _ as xs -> 10 | let len = Array.length xs in 11 | let xs2 = Array.make len (f 0 xs.(0)) in 12 | for i = 0 to len - 1 do 13 | xs2.(i) <- f i xs.(i) 14 | done; 15 | xs2 16 | 17 | let map2 f xs ys = 18 | let n = Array.length xs in 19 | if n <> Array.length ys then raise (Invalid_argument "map2") 20 | else Array.init n (fun i -> f xs.(i) ys.(i)) 21 | 22 | let swap i j xs = 23 | let elm_j = xs.(j) in 24 | xs.(j) <- xs.(i); 25 | xs.(i) <- elm_j 26 | 27 | let rec swap_region s1 len1 s2 len2 xs = 28 | if s1 > s2 then 29 | swap_region s2 len2 s1 len1 xs 30 | else if s1 < 0 || s2 + len2 > Array.length xs || s1 + len1 > s2 then 31 | invalid_arg "swap_region" 32 | else 33 | let left = Array.sub xs s1 len1 34 | and center = Array.sub xs (s1 + len1) (s2 - s1 - len1) 35 | in 36 | Array.blit xs s2 xs s1 len2; 37 | Array.blit center 0 xs (s1 + len2) (s2 - s1 - len1); 38 | Array.blit left 0 xs (s2 - len1 + len2) len1 39 | 40 | let find_max ?(comp = Pervasives.compare) f xs = 41 | if Array.length xs = 0 then 42 | raise (Invalid_argument "find_max") 43 | else 44 | Array.fold_left (fun x y -> if comp (f x) (f y) > 0 then x else y) xs.(0) xs 45 | 46 | let find_min ?(comp = Pervasives.compare) = 47 | find_max ~comp:(swap_arg comp) 48 | 49 | let find_max_num ?(comp = Pervasives.compare) f xs = 50 | if Array.length xs = 0 then 51 | raise (Invalid_argument "find_max_num") 52 | else 53 | let max_i = ref 0 54 | and max = ref xs.(0) 55 | and fmax = ref (f xs.(0)) in 56 | let test i x = 57 | let fx = f x in 58 | if comp fx !fmax > 0 then begin 59 | max_i := i; 60 | max := x; 61 | fmax := fx end 62 | else 63 | () in 64 | Array.iteri test xs; 65 | !max_i 66 | 67 | let find_min_num ?(comp = Pervasives.compare) = find_max_num ~comp:(swap_arg comp) 68 | 69 | 70 | (* For loop escapement. *) 71 | exception Found of int option 72 | 73 | let find_num_left ?(start = 0) cond xs = 74 | match 75 | try 76 | for i = start to Array.length xs - 1 do 77 | if cond xs.(i) then raise (Found (Some i)) 78 | done; 79 | None 80 | with 81 | Found x -> x 82 | with 83 | Some x -> x 84 | | None -> raise Not_found 85 | 86 | let find_num_right ?(start = 0) cond xs = 87 | let len = Array.length xs in 88 | match 89 | try 90 | for i = start + 1 to len do 91 | if cond xs.(len - i) then raise (Found (Some i)) 92 | done; 93 | None 94 | with 95 | Found x -> x 96 | with 97 | Some x -> len - x 98 | | None -> raise Not_found 99 | 100 | let split n xs = (Array.sub xs 0 n, Array.sub xs n (Array.length xs - n)) 101 | 102 | let for_all cond xs = Array.fold_left (fun p x -> p && cond x) true xs 103 | 104 | let for_all2 cond xs ys = 105 | let n = Array.length xs in 106 | if n <> Array.length ys then raise (Invalid_argument "for_all2") 107 | else 108 | let p = ref true in 109 | let _ = 110 | for i = 0 to n - 1 do 111 | if not (cond xs.(i) ys.(i)) then p := false 112 | done 113 | in 114 | !p 115 | 116 | (* let exists cond xs = Array.fold_left (fun p x -> p || cond x) false xs *) 117 | 118 | exception Found 119 | 120 | let exists cond xs = 121 | try 122 | for i = 0 to Array.length xs - 1 do 123 | if cond xs.(i) then raise Found 124 | done; 125 | false 126 | with Found -> true 127 | 128 | let permutate order xs = 129 | let n = Array.length xs in 130 | if List.length order <> n then raise (Invalid_argument "Array length must be the same."); 131 | let a = Array.make n xs.(0) in 132 | let rec permutate_aux m = function 133 | [] -> a 134 | | hd :: tl -> a.(m) <- xs.(hd); permutate_aux (m + 1) tl 135 | in 136 | permutate_aux 0 order 137 | 138 | let count p xs = Array.fold_left (fun n x -> if p x then n + 1 else n) 0 xs 139 | 140 | let filter_some xs = 141 | Array.to_list xs |> UtilList.filter_some |> Array.of_list 142 | 143 | let select_rand n xs = 144 | let m = Array.length xs - n in 145 | if n < 0 || m < 0 then raise (Invalid_argument "select_rand"); 146 | let xs = Array.map (fun x -> Some x) xs in 147 | let rec aux k = 148 | if k >= m then 149 | filter_some xs 150 | else 151 | let to_delete = Random.int (Array.length xs - k) in 152 | let rec aux2 i j = 153 | match xs.(j) with 154 | Some _ -> if i = to_delete then xs.(j) <- None else aux2 (i + 1) (j + 1) 155 | | None -> aux2 i (j + 1) 156 | in 157 | aux2 0 0; 158 | aux (k + 1) 159 | in 160 | aux 0 161 | -------------------------------------------------------------------------------- /util/utilArray.mli: -------------------------------------------------------------------------------- 1 | (** Extended Array Module. *) 2 | 3 | (** Print elements in an array. Function which converts an element to some string representation is needed. *) 4 | val print : ('a -> string) -> 'a array -> unit 5 | 6 | val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array 7 | val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array 8 | 9 | (** Swap two elements at the designated locations. destructive. *) 10 | val swap : int -> int -> 'a array -> unit 11 | 12 | val swap_region : int -> int -> int -> int -> 'a array -> unit 13 | 14 | val find_max : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a array -> 'a 15 | 16 | val find_min : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a array -> 'a 17 | 18 | val find_max_num : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a array -> int 19 | 20 | val find_min_num : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a array -> int 21 | 22 | (** Scan an array from left and return the index of the first element which satisfies cond. *) 23 | val find_num_left : ?start:int -> ('a -> bool) -> 'a array -> int 24 | 25 | (** Same to find_num_left, but scanning starts from right. *) 26 | val find_num_right : ?start:int -> ('a -> bool) -> 'a array -> int 27 | 28 | (** Split array at just left the nth element. *) 29 | val split : int -> 'a array -> 'a array * 'a array 30 | 31 | (** Same to that of List *) 32 | val for_all : ('a -> bool) -> 'a array -> bool 33 | val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool 34 | 35 | (** Same to that of List *) 36 | val exists : ('a -> bool) -> 'a array -> bool 37 | val permutate : int list -> 'a array -> 'a array 38 | 39 | val count : ('a -> bool) -> 'a array -> int 40 | val filter_some : 'a option array -> 'a array 41 | val select_rand : int -> 'a array -> 'a array 42 | -------------------------------------------------------------------------------- /util/utilList.ml: -------------------------------------------------------------------------------- 1 | open UtilPervasives 2 | 3 | let iteri f xs = 4 | let rec aux n = function 5 | | [] -> () 6 | | hd :: tl -> f n hd; aux (n + 1) tl 7 | in 8 | aux 0 xs 9 | 10 | let sub start len xs = 11 | try 12 | let rec skip i xs = 13 | if i = start then xs 14 | else skip (i + 1) (List.tl xs) 15 | and drop j acc xs = 16 | if j = len then List.rev acc 17 | else drop (j + 1) (List.hd xs :: acc) (List.tl xs) 18 | in 19 | skip 0 xs |> drop 0 [] 20 | with Failure "tl" -> invalid_arg "Util.List.sub" 21 | 22 | let take n xs = 23 | let rec aux n xs accum = 24 | if n <= 0 || xs = [] then List.rev accum 25 | else aux (n - 1) (List.tl xs) (List.hd xs :: accum) 26 | in 27 | aux n xs [] 28 | 29 | let take_option n_option xs = 30 | let rec aux n xs acc = 31 | if n <= 0 then List.rev acc 32 | else match xs with 33 | | [] -> List.rev acc 34 | | l :: r -> aux (n - 1) r (l :: acc) in 35 | match n_option with 36 | | None -> xs 37 | | Some n -> aux n xs [] 38 | 39 | let rec take_even_aux acc is_even = function 40 | | [] -> List.rev acc 41 | | l :: r -> take_even_aux (if is_even then (l :: acc) else acc) (not is_even) r 42 | 43 | let take_even xs = take_even_aux [] true xs 44 | 45 | let take_odd xs = take_even_aux [] false xs 46 | 47 | let rec drop n xs = 48 | if n <= 0 || xs = [] then xs 49 | else drop (n - 1) (List.tl xs) 50 | 51 | let rec split_at n xs = 52 | let rec aux n xs acc = 53 | if n <= 0 || xs = [] then List.rev acc, xs 54 | else aux (n - 1) (List.tl xs) (List.hd xs :: acc) 55 | in 56 | aux n xs [] 57 | 58 | let rec drop_while p xs = 59 | if xs = [] then [] 60 | else if p (List.hd xs) then drop_while p (List.tl xs) 61 | else xs 62 | 63 | let delete_nth n xs = 64 | if n < 0 then 65 | raise (Invalid_argument "Util.List.delete_nth") 66 | else if n = 0 then 67 | List.tl xs 68 | else if n = 1 then 69 | List.hd xs :: (List.tl (List.tl xs)) 70 | else 71 | let tl_field xsr = Obj.field xsr 1 in 72 | let rec aux n xsr_orig xsr = 73 | let tl = xsr |> tl_field |> tl_field in 74 | if n > 0 && Obj.obj tl = 0 then 75 | raise (Invalid_argument "Util.List.delete_nth") 76 | else if n = 0 then let _ = begin 77 | if Obj.obj tl = 0 then 78 | Obj.set_field xsr 1 (Obj.repr 0) 79 | else 80 | Obj.set_field xsr 1 tl 81 | end in Obj.obj xsr_orig 82 | else aux (n - 1) xsr_orig (Obj.field xsr 1) 83 | in 84 | aux (n - 1) (Obj.repr xs) (Obj.repr xs |> Obj.dup) 85 | 86 | let delete_nth_naive n xs = 87 | let rec aux n xs accum = 88 | if n <= 0 then List.rev accum @ List.tl xs 89 | else aux (n - 1) (List.tl xs) (List.hd xs :: accum) 90 | in 91 | aux n xs [] 92 | 93 | let is_empty xs = List.length xs = 0 94 | 95 | let single xs = if List.length xs = 1 then List.hd xs else 96 | raise (Invalid_argument "Util.List.single: The length of the list must be 1.") 97 | 98 | let last xs = List.nth xs (List.length xs - 1) 99 | 100 | let to_chain = function (* ex. [1;2;3] -> [(1, 2); (2, 3)]*) 101 | [] | [_] -> [] 102 | | hd :: tl -> 103 | let rec to_chain_aux accum = function 104 | | [] -> failwith "Util.List.to_chain : fatal error." 105 | | [last] -> List.rev accum 106 | | hd :: tl -> to_chain_aux ((hd, List.hd tl) :: accum) tl 107 | in 108 | to_chain_aux [hd, List.hd tl] tl 109 | 110 | let filter_some xs = List.filter (fun x -> match x with Some _ -> true | None -> false) xs 111 | |> List.map (function Some y -> y | None -> failwith "Util.List.filter_some: fatal error") 112 | 113 | let rec print_int_list = function 114 | | [] -> Printf.printf "\n" 115 | | hd :: tl -> Printf.printf "%d " hd; print_int_list tl 116 | 117 | let rec print_float_list = function 118 | | [] -> Printf.printf "\n" 119 | | hd :: tl -> Printf.printf "%d " hd; print_float_list tl 120 | 121 | let remove cond = 122 | let rec remove_aux accum = function 123 | | [] -> List.rev accum (* unfound *) 124 | | hd :: tl -> if cond hd then List.rev accum @ tl else remove_aux (hd :: accum) tl 125 | in 126 | remove_aux [] 127 | 128 | let find_max ?(comp = Pervasives.compare) f xs = 129 | let rec aux (max, max_val) = function 130 | | [] -> max 131 | | l :: r -> 132 | let y = f l in 133 | aux (if comp y max_val > 0 then l, y else max, max_val) r in 134 | match xs with 135 | | [] -> raise (Invalid_argument "Util.List.find_max") 136 | | l :: r -> aux (l, f l) r 137 | 138 | let find_min ?(comp = Pervasives.compare) = find_max ~comp:(swap_arg comp) 139 | 140 | let find_max_val ?(comp = Pervasives.compare) f = function 141 | | [] -> invalid_arg "Util.List.find_max_val_with" 142 | | hd :: tl -> List.fold_left (fun x y -> let fy = f y in if comp x fy > 0 then x else fy) (f hd) tl 143 | 144 | let find_min_val ?(comp = Pervasives.compare) = find_max_val ~comp:(swap_arg comp) 145 | 146 | let mapi f = 147 | let rec mapi_aux f accum n = function 148 | | [] -> List.rev accum 149 | | x :: xs -> mapi_aux f (f n x :: accum) (n + 1) xs 150 | in 151 | mapi_aux f [] 0 152 | 153 | let count cond xs = List.filter cond xs |> List.length 154 | 155 | let rev_flatten xs = 156 | let rec rev_flatten_aux accum = function 157 | | [] -> accum 158 | | hd :: tl -> 159 | let rec rev_flatten_deep accum = function 160 | | [] -> accum 161 | | hd :: tl -> rev_flatten_deep (hd :: accum) tl 162 | in 163 | rev_flatten_aux (rev_flatten_deep accum hd) tl 164 | in 165 | rev_flatten_aux [] xs 166 | 167 | let flatten xs = rev_flatten xs |> List.rev 168 | 169 | let concat = flatten 170 | 171 | let init f n = 172 | let rec init_aux n accum = 173 | if n <= 0 then accum else 174 | init_aux (n - 1) (f (n - 1) :: accum) 175 | in 176 | init_aux n [] 177 | 178 | let make n x = 179 | let rec make_aux n accum = 180 | if n <= 0 then accum else 181 | make_aux (n - 1) (x :: accum) 182 | in 183 | make_aux n [] 184 | 185 | let map_orig = List.map 186 | 187 | let map f = 188 | let rec aux accum = function 189 | | [] -> List.rev accum 190 | | hd :: tl -> aux (f hd :: accum) tl 191 | in 192 | aux [] 193 | 194 | let average_first n lst = 195 | let n = min n (List.length lst) in 196 | let rec sum_first n accum lst= 197 | if n = 0 then accum else 198 | match lst with 199 | | [] -> invalid_arg "Util.List.average_first" 200 | | hd :: tl -> sum_first (n - 1) (hd +. accum) tl 201 | in 202 | (sum_first n 0. lst) /. float n 203 | 204 | let average lst = 205 | average_first (List.length lst) lst 206 | 207 | let split_while f lst = 208 | let rec split_while_aux f accum_fst accum_snd = function 209 | | [] -> (List.rev accum_fst, accum_snd) 210 | | hd :: tl -> 211 | if f hd then 212 | split_while_aux f (hd :: accum_fst) tl tl 213 | else 214 | (List.rev accum_fst, accum_snd) 215 | in 216 | split_while_aux f [] lst lst 217 | 218 | let range a b inc = 219 | let rec aux a b inc accum = 220 | if a > b then accum 221 | else aux a (b - inc) inc (b :: accum) 222 | in 223 | if inc = 0 then raise (Invalid_argument "Util.List.range : increment must be positive.") 224 | else if inc > 0 && a <= b then aux a (b - (b - a) mod inc) inc [] 225 | else if inc < 0 && a >= b then aux b a (-inc) [] |> List.rev 226 | else [] 227 | 228 | let take_ns ns lst = 229 | let rec take_ns_aux ns lst l accum = 230 | if lst == [] || ns == [] then List.rev accum else 231 | if l == List.hd ns then 232 | take_ns_aux (List.tl ns) (List.tl lst) (l + 1) (List.hd lst :: accum) 233 | else 234 | take_ns_aux ns (List.tl lst) (l + 1) accum 235 | in 236 | take_ns_aux ns lst 0 [] (* preserves order *) 237 | 238 | let random_permutation n = 239 | let rec aux accum emerged n = 240 | if n <= 0 then accum 241 | else 242 | let r = Random.int n in 243 | let r = IntSet.fold (fun e r -> if e <= r then r + 1 else r) emerged r in 244 | aux (r :: accum) (IntSet.add r emerged) (n - 1) 245 | in 246 | aux [] IntSet.empty n 247 | 248 | let remove_adjacent = function 249 | | [] -> [] 250 | | hd :: tl -> 251 | let rec aux pred accum xs = 252 | match xs with 253 | | [] -> List.rev accum 254 | | hd :: tl -> if hd = pred then aux pred accum tl else aux hd (hd :: accum) tl 255 | in 256 | aux hd [hd] tl 257 | 258 | let remove_adjacent_tuple m xs = 259 | let rec remove pattern xs = (* Some : succeed to remove, None : failed to remove *) 260 | if pattern = [] then 261 | Some xs 262 | else if xs = [] then 263 | None 264 | else if List.hd pattern = List.hd xs then 265 | remove (List.tl pattern) (List.tl xs) 266 | else 267 | None 268 | in 269 | let rec remove_eager pattern xs = 270 | match remove pattern xs with 271 | | None -> xs 272 | | Some xs' -> remove_eager pattern xs' 273 | in 274 | let rec aux pred xs accum = 275 | let removed = remove_eager pred xs in 276 | if removed = [] then 277 | List.rev accum 278 | else 279 | aux (List.tl pred @ [List.hd removed]) (List.tl removed) (List.hd removed :: accum) 280 | in 281 | aux (take m xs) (drop m xs) (take m xs |> List.rev) 282 | 283 | let n_divide n k = 284 | if n <= 0 || k <= 0 then raise (Invalid_argument "Util.List.n_divide"); 285 | let rec aux n k = 286 | if k = 1 then 287 | [[n]] 288 | else 289 | let rec aux2 n k i accum = 290 | if i <= 0 then accum 291 | else 292 | let shorten = List.map (fun xs -> i :: xs) (aux (n - i) (k - 1)) in 293 | aux2 n k (i - 1) (shorten @ accum) 294 | in 295 | aux2 n k (n - 1) [] 296 | in 297 | aux n k 298 | 299 | let combination n m = 300 | let g (k, r) = init (fun i -> k + int_exp 2 (n - i - 1), i) r in 301 | let rec aux m xs = 302 | if m = 1 then 303 | map fst xs 304 | else 305 | aux (m - 1) (map g xs |> List.concat) 306 | in 307 | aux m (init (fun i -> int_exp 2 i, n - i - 1) n);; 308 | 309 | let remove_duplicated f = 310 | let rec aux acc = function 311 | | [] -> acc 312 | | x :: xs -> 313 | if List.exists ((=) (f x)) (map f acc) then aux acc xs 314 | else aux (x :: acc) xs in 315 | aux [] 316 | 317 | let remove_duplicated xs = 318 | let open Hashtbl in 319 | let table = create 100 in 320 | List.iter (fun x -> replace table x ()) xs; 321 | fold (fun x () acc -> x :: acc) table [] 322 | 323 | let tuplize xs ys = 324 | List.map (fun x -> List.map (fun y -> (x, y)) ys) xs |> List.flatten 325 | 326 | let pack ?(comp = Pervasives.compare) xs = 327 | let rec aux last count acc = function 328 | | [] -> (last, count) :: acc 329 | | l :: r when comp last l = 0 -> aux last (count + 1) acc r 330 | | l :: r -> aux l 1 ((last, count) :: acc) r in 331 | match List.sort comp xs with 332 | | [] -> [] 333 | | l :: r -> aux l 1 [] r 334 | 335 | let filter_map f xs = 336 | let rec aux acc = function 337 | | [] -> List.rev acc 338 | | l :: r -> match f l with 339 | | Some x -> aux (x :: acc) r 340 | | None -> aux acc r in 341 | aux [] xs 342 | -------------------------------------------------------------------------------- /util/utilList.mli: -------------------------------------------------------------------------------- 1 | (** Extended List Module. *) 2 | 3 | val iteri : (int -> 'a -> unit) -> 'a list -> unit 4 | val sub : int -> int -> 'a list -> 'a list 5 | val take : int -> 'a list -> 'a list 6 | val take_option : int option -> 'a list -> 'a list 7 | val take_even : 'a list -> 'a list 8 | val take_odd : 'a list -> 'a list 9 | val drop : int -> 'a list -> 'a list 10 | val split_at : int -> 'a list -> 'a list * 'a list 11 | val drop_while : ('a -> bool) -> 'a list -> 'a list 12 | val delete_nth : int -> 'a list -> 'a list 13 | val delete_nth_naive : int -> 'a list -> 'a list 14 | val is_empty : 'a list -> bool 15 | val single : 'a list -> 'a 16 | val last : 'a list -> 'a 17 | val to_chain : 'a list -> ('a * 'a) list 18 | val filter_some : 'a option list -> 'a list 19 | val print_int_list : int list -> unit 20 | val print_float_list : int list -> unit 21 | 22 | (** remove cond xs removes the first element satisfies cond from xs.*) 23 | val remove : ('a -> bool) -> 'a list -> 'a list 24 | val find_max : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a list -> 'a 25 | val find_min : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a list -> 'a 26 | val find_max_val : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a list -> 'b 27 | val find_min_val : ?comp:('b -> 'b -> int) -> ('a -> 'b) -> 'a list -> 'b 28 | val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list 29 | val count : ('a -> bool) -> 'a list -> int 30 | val rev_flatten : 'a list list -> 'a list 31 | val flatten : 'a list list -> 'a list 32 | val concat : 'a list list -> 'a list 33 | val init : (int -> 'a) -> int -> 'a list 34 | val make : int -> 'a -> 'a list 35 | val map_orig : ('a -> 'b) -> 'a list -> 'b list 36 | val map : ('a -> 'b) -> 'a list -> 'b list 37 | val average_first : int -> float list -> float 38 | val average : float list -> float 39 | val split_while : ('a -> bool) -> 'a list -> 'a list * 'a list 40 | val range : int -> int -> int -> int list 41 | val take_ns : int list -> 'a list -> 'a list 42 | val random_permutation : int -> int list 43 | val remove_adjacent : 'a list -> 'a list 44 | val remove_adjacent_tuple : int -> 'a list -> 'a list 45 | val n_divide : int -> int -> int list list 46 | 47 | (** ex. combination 4 2 returns [1001; 0101; 0011; 1010; 0110; 1100] (in binary). *) 48 | val combination : int -> int -> int list 49 | 50 | (** If x appeared earlier than y in the list and f x = f y then y is removed. The order of the list is not preserved. *) 51 | val remove_duplicated : 'a list -> 'a list 52 | val tuplize : 'a list -> 'b list -> ('a * 'b) list 53 | val pack : ?comp:('a -> 'a -> int) -> 'a list -> ('a * int) list 54 | val filter_map : ('a -> 'b option) -> 'a list -> 'b list 55 | -------------------------------------------------------------------------------- /util/utilPervasives.ml: -------------------------------------------------------------------------------- 1 | external identity : 'a -> 'a = "%identity" 2 | 3 | let (|>) f x = x f 4 | 5 | let (<|) f x = f x 6 | 7 | let ($) f g x = f (g x) 8 | 9 | let swap (a, b) = (b, a) 10 | 11 | let swap_arg f x y = f y x 12 | 13 | let maxf f x y = max (f x) (f y) 14 | 15 | let xor x y = x && (not y) || y && (not x) 16 | 17 | let incr x = x := !x + 1 18 | 19 | let triple1 (x, _, _) = x 20 | let triple2 (_, x, _) = x 21 | let triple3 (_, _, x) = x 22 | 23 | let quad1 (x, _, _, _) = x 24 | let quad2 (_, x, _, _) = x 25 | let quad3 (_, _, x, _) = x 26 | let quad4 (_, _, _, x) = x 27 | 28 | let pi = atan 1. *. 4. 29 | 30 | let rec iter n f x = 31 | if n <= 0 then () 32 | else begin 33 | f x; 34 | iter (n - 1) f x 35 | end;; 36 | 37 | let time timer n f x = 38 | let start = timer () in 39 | iter n f x; 40 | (timer () -. start) /. float n 41 | 42 | let rec bisection f a b = 43 | let (fa, fb, c) = f a, f b, (a +. b) /. 2. 44 | and is_same_sign x y = 45 | let sign x = if x > 0. then true else false in 46 | (sign x && sign y) || (not (sign x) && not (sign y)) 47 | in 48 | if a > b || classify_float a = FP_infinite || classify_float b = FP_infinite then 49 | raise (Invalid_argument "bisection") 50 | else if is_same_sign fa fb then bisection f (2. *. a -. c) (2. *. b -. c) 51 | else if abs_float (f c) < 10e-9 then c 52 | else if is_same_sign fa (f c) then bisection f c b 53 | else bisection f a c 54 | 55 | let is_even_list x = 56 | if x < 0 then invalid_arg "is_even_list"; 57 | let rec aux x accum = 58 | if x = 0 then accum 59 | else if (x mod 2 = 0) then aux (x lsr 1) (true::accum) 60 | else aux (x lsr 1) (false::accum) 61 | in 62 | aux x [] 63 | 64 | let general_exp one mul x y = 65 | let rec aux accum = function 66 | [] -> accum 67 | | hd :: tl -> aux (mul (mul accum accum) (if hd then one else x)) tl 68 | in 69 | aux one (is_even_list y) 70 | 71 | let int_exp = general_exp 1 ( * ) 72 | 73 | let minimum_bigger_power_of_two n = 74 | if n = 0 then -1 else 75 | let rec aux accum = function 76 | 0 -> accum 77 | | m -> aux (accum + 1) (m lsr 1) 78 | in 79 | aux 0 (n-1) 80 | 81 | let string_of_option to_string = function 82 | None -> "None" 83 | | Some x -> to_string x 84 | 85 | let box_muller () = 86 | let rand () = 1. -. Random.float 1. in 87 | let (a, b) = rand (), rand () in 88 | sqrt (-2. *. log a) *. sin (2. *. pi *. b), 89 | sqrt (-2. *. log b) *. sin (2. *. pi *. a) 90 | 91 | module Int = struct type t = int let compare = compare end 92 | module IntSet' = Set.Make (Int) 93 | module IntSet = struct 94 | include IntSet' 95 | let add_list = List.fold_left (swap_arg IntSet'.add) 96 | let print s = IntSet'.iter (Printf.printf "%d ") s; Printf.printf "\n" 97 | end 98 | 99 | module Queue2 : sig 100 | type 'a t 101 | val empty : 'a t 102 | val is_empty : 'a t -> bool 103 | val length : 'a t -> int 104 | val singleton : 'a -> 'a t 105 | val push : 'a -> 'a t -> 'a t 106 | val pop : 'a t -> 'a * 'a t 107 | val peek : 'a t -> 'a 108 | end = struct 109 | type 'a t = 'a list * 'a list 110 | let empty = ([], []) 111 | let is_empty (l, r) = (l = []) && (r = []) 112 | let length (l, r) = List.length l + List.length r 113 | let singleton e = ([], [e]) 114 | let push e (l, r) = (l, e :: r) 115 | let rec pop (l, r) = match l with 116 | [] -> pop (List.rev r, []) 117 | | hd :: tl -> (hd, (tl, r)) 118 | let rec peek (l, r) = match l with 119 | [] -> peek (List.rev r, []) 120 | | hd :: tl -> hd 121 | end 122 | 123 | module Stack2 : sig 124 | type 'a t 125 | val empty : 'a t 126 | val singleton : 'a -> 'a t 127 | val is_empty : 'a t -> bool 128 | val length : 'a t -> int 129 | val push : 'a -> 'a t -> 'a t 130 | val pop : 'a t -> 'a * 'a t 131 | val remove : 'a t -> 'a t 132 | val peek : 'a t -> 'a 133 | end = struct 134 | type 'a t = 'a list 135 | exception Empty 136 | let empty = [] 137 | let singleton x = [x] 138 | let is_empty = function [] -> true | _ -> false 139 | let length = List.length 140 | let push x q = x :: q 141 | let pop = function 142 | [] -> raise Empty 143 | | hd :: tl -> (hd, tl) 144 | let remove = function 145 | [] -> raise Empty 146 | | hd :: tl -> tl 147 | let peek = function 148 | [] -> raise Empty 149 | | hd :: tl -> hd 150 | end 151 | 152 | (* reference : http://d.hatena.ne.jp/blanketsky/20070221/1172002969 *) 153 | module LazyList(* : sig 154 | type 'a t 155 | val from : int -> int t 156 | val head : 'a t -> 'a 157 | val tail : 'a t -> 'a t 158 | val take : int -> 'a t -> 'a list 159 | val map : ('a -> 'b) -> 'a t -> 'b t 160 | val nth : int -> 'a t -> 'a 161 | val primes : int t 162 | end *) 163 | = 164 | struct 165 | type 'a t = Cons of 'a * ('a t lazy_t) 166 | 167 | let rec from n = Cons (n, lazy (from (n+1))) 168 | 169 | let head (Cons (x, _)) = x 170 | let tail (Cons (_, xs)) = Lazy.force xs 171 | 172 | let take n s = 173 | let rec take' m (Cons (x, xs)) l = 174 | if m = 0 then List.rev l 175 | else take' (m-1) (Lazy.force xs) (x :: l) 176 | in 177 | take' n s [] 178 | 179 | let rec map f (Cons (x, xs)) = 180 | Cons (f x, lazy (map f (Lazy.force xs))) 181 | 182 | let rec nth n (Cons (x, xs)) = 183 | if n = 1 then x 184 | else nth (n-1) (Lazy.force xs) 185 | 186 | (* remove multiples of n *) 187 | let rec sift n (Cons (x, xs)) = 188 | if x mod n <> 0 then Cons (x, lazy (sift n (Lazy.force xs))) 189 | else sift n (Lazy.force xs) 190 | 191 | let rec sieve (Cons (x, xs)) = 192 | Cons (x, lazy (sieve (sift x (Lazy.force xs)))) 193 | 194 | let primes = sieve (from 2) 195 | end 196 | 197 | -------------------------------------------------------------------------------- /util/utilPervasives.mli: -------------------------------------------------------------------------------- 1 | (** Extended Pervasives module. *) 2 | 3 | val identity : 'a -> 'a 4 | val ( |> ) : 'a -> ('a -> 'b) -> 'b 5 | val ( <| ) : ('a -> 'b) -> 'a -> 'b 6 | val ( $ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 7 | val swap : 'a * 'b -> 'b * 'a 8 | val swap_arg : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c 9 | val maxf : ('a -> 'b) -> 'a -> 'a -> 'b 10 | val xor : bool -> bool -> bool 11 | val incr : int ref -> unit 12 | val triple1 : 'a * 'b * 'c -> 'a 13 | val triple2 : 'a * 'b * 'c -> 'b 14 | val triple3 : 'a * 'b * 'c -> 'c 15 | val quad1 : 'a * 'b * 'c * 'd -> 'a 16 | val quad2 : 'a * 'b * 'c * 'd -> 'b 17 | val quad3 : 'a * 'b * 'c * 'd -> 'c 18 | val quad4 : 'a * 'b * 'c * 'd -> 'd 19 | val pi : float 20 | val iter : int -> ('a -> 'b) -> 'a -> unit 21 | val time : (unit -> float) -> int -> ('a -> 'b) -> 'a -> float 22 | val bisection : (float -> float) -> float -> float -> float 23 | val is_even_list : int -> bool list 24 | val general_exp : 'a -> ('a -> 'a -> 'a) -> 'a -> int -> 'a 25 | val int_exp : int -> int -> int 26 | val minimum_bigger_power_of_two : int -> int 27 | val string_of_option : ('a -> string) -> 'a option -> string 28 | val box_muller : unit -> float * float 29 | module IntSet : 30 | sig 31 | type elt = int 32 | type t 33 | val empty : t 34 | val is_empty : t -> bool 35 | val mem : elt -> t -> bool 36 | val add : elt -> t -> t 37 | val singleton : elt -> t 38 | val remove : elt -> t -> t 39 | val union : t -> t -> t 40 | val inter : t -> t -> t 41 | val diff : t -> t -> t 42 | val compare : t -> t -> int 43 | val equal : t -> t -> bool 44 | val subset : t -> t -> bool 45 | val iter : (elt -> unit) -> t -> unit 46 | val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a 47 | val for_all : (elt -> bool) -> t -> bool 48 | val exists : (elt -> bool) -> t -> bool 49 | val filter : (elt -> bool) -> t -> t 50 | val partition : (elt -> bool) -> t -> t * t 51 | val cardinal : t -> int 52 | val elements : t -> elt list 53 | val min_elt : t -> elt 54 | val max_elt : t -> elt 55 | val choose : t -> elt 56 | val split : elt -> t -> t * bool * t 57 | val add_list : t -> int list -> t 58 | val print : t -> unit 59 | end 60 | module Queue2 : 61 | sig 62 | type 'a t 63 | val empty : 'a t 64 | val is_empty : 'a t -> bool 65 | val length : 'a t -> int 66 | val singleton : 'a -> 'a t 67 | val push : 'a -> 'a t -> 'a t 68 | val pop : 'a t -> 'a * 'a t 69 | val peek : 'a t -> 'a 70 | end 71 | 72 | (* 73 | reference : Okasaki, C. (1995) Simple and Efficient Purely Functional Queues and Deques. J. Functional Programming, 5(4), 583–592. 74 | *) 75 | module Stack2 : 76 | sig 77 | type 'a t 78 | val empty : 'a t 79 | val singleton : 'a -> 'a t 80 | val is_empty : 'a t -> bool 81 | val length : 'a t -> int 82 | val push : 'a -> 'a t -> 'a t 83 | val pop : 'a t -> 'a * 'a t 84 | val remove : 'a t -> 'a t 85 | val peek : 'a t -> 'a 86 | end 87 | module LazyList : 88 | sig 89 | type 'a t = Cons of 'a * 'a t lazy_t 90 | val from : int -> int t 91 | val head : 'a t -> 'a 92 | val tail : 'a t -> 'a t 93 | val take : int -> 'a t -> 'a list 94 | val map : ('a -> 'b) -> 'a t -> 'b t 95 | val nth : int -> 'a t -> 'a 96 | val sift : int -> int t -> int t 97 | val sieve : int t -> int t 98 | val primes : int t 99 | end 100 | --------------------------------------------------------------------------------