Latest comments for language 'OCaml' on doukaku.org

kanai's comment on 世界時計

初めての投稿です。もっと格好良く書きたいのですが...
Ubuntu 8.10 で ocamlopt -o doukaku unix.cmxa doukaku.mlでコンパイル後
./doukakuで
現在の時刻は、2008年11月13日 13時25分16秒です。
グリニッジ標準時刻は、2008年11月13日 4時25分16秒です。
アメリカ・ロサンゼルスの時刻は、2008年11月12日 20時25分16秒です。
のように表示できています。

open Unix;;

let current_time = time();;
let local_time = localtime(current_time);;
putenv "TZ" "America/Los_Angeles";;
let us_time = localtime(current_time);;
let gm_time = gmtime(current_time);;

let print_time locate time =
  Printf.printf "%s時刻は、%d年%d月%d日 %d時%d分%d秒です。\n" locate (time.tm_year + 1900) (time.tm_mon + 1) time.tm_mday time.tm_hour time.tm_min time.tm_sec;;

print_time "現在の" local_time;;
print_time "グリニッジ標準" gm_time;;
print_time "アメリカ・ロサンゼルスの" us_time;;

[ OCaml ] [ download code ] ]

ocaml-nagoya's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

スレッドつくって画面表示。最後のThread.delayは、これが無いとすぐに実行が終了してしまうので、待ちを入れる意味です。

open Format
  
let spawn_loop f x =
  let rec forever f x = 
    let v = f x in forever f v
  in
  ignore (Thread.create (forever f) x)
    
let _ =
  spawn_loop (fun () ->
    List.iter (fprintf std_formatter "%d@?")  [1; 2; 3; 4; 5; 6; 7; 8; 9; 10;]) ();
  spawn_loop (fun () ->
    List.iter (fprintf std_formatter "%c@?")  ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J']) ();
  Thread.delay 10.

[ OCaml ] [ download code ] ]

komamitsu's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

Thread.yield だと切り替わらなかったのでThread.delayを使いました。

(* ocamlc -thread -o para unix.cma threads.cma para.ml *)

let para printer lst =
  Thread.create
  (fun lst ->
    List.iter
    (fun x ->
      printer x;
      flush stdout;
      Thread.delay 0.1) lst) lst

let _ =
  List.iter
  (fun t -> Thread.join t)
  [ para (fun c -> Printf.printf "%c " c)
    ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'];
    para (fun i -> Printf.printf "%d " i)
    [1; 2; 3; 4; 5; 6; 7; 8; 9; 10] ]

[ OCaml ] [ download code ] ]

susu's comment on '('と')'の対応

'('と')'の対応 (Nested Flatten)

(* #! /usr/bin/env ocaml *)
let paren_test l r s =
  let count = ref 0 in
  let f c =
    if c = r then 
      if !count=0 then raise Exit else decr count
    else if c = l then 
      incr count 
  in try String.iter f s; !count = 0 with Exit -> false;;

if not !Sys.interactive && Array.length Sys.argv >= 2 then
  let s = Array.get Sys.argv 1 in
  let result = paren_test '\040' '\041' s in
  Printf.printf "%s: %B\n" s result
;;

[ OCaml ] [ download code ] ]

kozima's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

組み込みの数値を一切使わないで書いてみました。わりと教科書的。

type digit = | Zero | One | Two | Three | Four | Five
             | Six | Seven | Eight | Nine

let next_digit = function
    Zero -> One | One -> Two | Two -> Three | Three -> Four
  | Four -> Five | Five -> Six | Six -> Seven | Seven -> Eight
  | Eight -> Nine | Nine -> raise (Invalid_argument "next_digit, nine")
let prev_digit = function
    One -> Zero | Two -> One | Three -> Two | Four -> Three
  | Five -> Four | Six -> Five | Seven -> Six | Eight -> Seven
  | Nine -> Eight | Zero -> raise (Invalid_argument "prev_digit, zero")

let succ = function
  | (Nine, Nine) -> raise (Invalid_argument "succ, ninety-nine")
  | (x, Nine)    -> (next_digit x, Zero)
  | (x, y)       -> (x, next_digit y)
let pred = function
  | (Zero, Zero) -> raise (Invalid_argument "pred, zero")
  | (x, Zero)    -> (prev_digit x, Nine)
  | (x, y)       -> (x, prev_digit y)
let rec (@+) m n =
  match m with
    | (Zero, Zero) -> n
    | _ -> succ (pred m @+ n)
let rec (@*) m n =
  if m = (Zero, Zero) then (Zero, Zero)
  else n @+ (pred m @* n)

let string_of_digit = function
  | Zero  -> "〇" | One   -> "一" | Two   -> "二" | Three -> "三"
  | Four  -> "四" | Five  -> "五" | Six   -> "六" | Seven -> "七"
  | Eight -> "八" | Nine  -> "九"
let string_of_number = function
  | (Zero, y) -> "  " ^ string_of_digit y
  | (x, y)    -> string_of_digit x ^ string_of_digit y

let digit_list = [One; Two; Three; Four; Five; Six; Seven; Eight; Nine]
let _ =
  let nums = List.map (fun x -> (Zero, x)) digit_list in
  let products = List.map (fun m -> List.map (fun n -> m @* n) nums) nums in
  let prod_strings = List.map (List.map string_of_number) products in
  let rows = List.map (String.concat "  ") prod_strings in
    List.iter print_endline rows

[ OCaml ] [ download code ] ]

susu's comment on コメントの削除

コメントの削除 (Nested Flatten)

付属の解析機を使ったあとに読み込んでいるだけです。
空白、改行、タブなどは捨てられてしまいます。

let decomment s = 
  Stream.iter (fun item ->
    print_string 
      (match item with
      | Kwd s | Ident s -> s
      | String s -> Printf.sprintf "\"%s\"" (String.escaped s)
      | Char c -> Printf.sprintf "'%s'" (Char.escaped c)
      | Int n -> string_of_int n
      | Float f -> string_of_float f
      ); print_char ' '
    ) (make_lexer [] (Stream.of_string s));;

(* decomment "aa\"(* bb \\\" cc *)\"dd '\\\\' (* zz *) ";; *)

[ OCaml ] [ download code ] ]

susu's comment on RFC 4180対応版 CSVレコードの分解

RFC 4180対応版 CSVレコードの分解 (Nested Flatten)

(*  ocaml camlp4rf.cma もしくは
    ocamlc -pp "camlp4rf" a.ml  *)

value add_opened_csv_string =
  let rec loop buf = parser
    [ [: `'"'; st:] -> 
        if (Stream.peek st <> Some '"') then ()
        else (Buffer.add_char buf (Stream.next st); loop buf st)
    | [: `c ; st :] -> (Buffer.add_char buf c; loop buf st) ]
  in fun buf st -> loop buf st;

value record_iteri =
  let use_buffer f buf = 
    (f (Buffer.contents buf); Buffer.clear buf) in
  let rec loop f pos buf  = parser
    [ [: `','; st:] -> (use_buffer (f pos) buf; loop f (pos+1) buf st)
    | [: `'\n'; st:] -> use_buffer (f pos) buf 
    | [: `'"'; st:] -> (add_opened_csv_string buf st; loop f pos buf st)
    | [: `c ; st:] -> (Buffer.add_char buf c; loop f pos buf st)
    | [: :] -> use_buffer (f pos) buf ]
  in fun st f buf -> loop f 1 buf st;

(*
value t = Stream.of_string "\
  \"aaa\",\"b\n\
  bb\",\"ccc\",zzz,\"y\"\"Y\"\"y\",xxx";

record_iteri t (Printf.printf "%2d => %s\n") (Buffer.create 8);
*)

[ OCaml ] [ download code ] ]

susu's comment on タブ区切りデータの処理

タブ区切りデータの処理 (Nested Flatten)

let succ_str s =
  try (string_of_int (int_of_string s + 1))
  with Failure _ -> s

let read scanbuf f =
  let t = "\t"  and nl = "\n"  in
  Scanf.bscanf scanbuf "%[^\t]\t%[^\t]\t%[^\t]\t%[^\n]%c"
  (fun a b c d _ -> f [a;t;c;t;b;t; succ_str d; nl])  

let f ch =
  let accu = ref [] in
  try
    read ch (List.iter print_string);
    while true do
      (read ch (fun l -> accu := l::!accu))
    done;
  with End_of_file ->
    let l = List.stable_sort (fun a b ->
      compare (List.hd a) (List.hd b)) !accu
    in List.iter (List.iter print_string) l;;
(*  
let s = "\
ID\tSurname\tForename\tAge
1\tSato\tHanako\t17
0\tSuzuki\tTaro\t18
"
let (path,o) = 
  Filename.open_temp_file "doukaku209_" ".txt";;
output_string o s;  close_out o;;

let sbuf = Scanf.Scanning.from_file path in (f sbuf);;
*)

[ OCaml ] [ download code ] ]

susu's comment on 起動オプションの解析

起動オプションの解析 (Nested Flatten)

資料としてArg版も。3,5,7には非対応です。

let switch t = if t then "ON" else "OFF"

let cmdopt arr = 
  let o = ref false 
  and q = ref false
  and d = ref "-"
  and args = Queue.create () in

  Arg.parse_argv ~current:(ref 0) arr
    [ "-o", Arg.Set o, "";
      "-q", Arg.Set q, "";
      "-d", Arg.Symbol (["0";"1";"2";], fun s -> d:=s),"";] 
    (fun anon -> Queue.push anon args) "";

  if not !o then raise Exit ;

  let len = Queue.length args in

  Printf.printf "\
    [オプション情報]\n\
    o(output)： %s\n\
    q(quote)： %s\n\
    d(debug)： %s\n\
    \n[パラメータ情報]\n指定数：%d \n"
    (switch !o) (switch !q) !d len;

  for i = 1 to len do 
    Printf.printf "%2d : %s \n" i (Queue.pop args);
  done;;

(* cmdopt [| "prog_name"; "-q"; "-o"; "aa"; "bb"|];; *)

[ OCaml ] [ download code ] ]

susu's comment on LL Golf Hole 8 - 横向きのピラミッドを作る

LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

let pyramid n = 
  for i = 1 to n*2 do
    print_endline (String.make (if i<n then i else n*2-i) '*');
  done;;

[ OCaml ] [ download code ] ]

susu's comment on 起動オプションの解析

起動オプションの解析 (Nested Flatten)

OCamlはまだ文字コードがeuc-jpでないと日本語がコンパイルできません。
それと、実行結果が文字化けしたらコンソールをeucで起動してください。

(* lv -Oej xx.ml > xx-ej.ml  euc-jpでない場合の変換
   xterm -en euc-jp & 
   ocaml -I +extlib extLib.cma xx-ej.ml
*)(*
  スクリプト用途時
  #!/usr/bin/env ocaml
  #directory "+extlib";;
  #load "extLib.cma";;
*)

let get = OptParse.Opt.get
let opt = OptParse.Opt.opt
let switch t = if t then "ON" else "OFF"
let debug = function
  | Some (0 | 1 | 2 as n) -> string_of_int n
  | _ -> "-";;

let t = OptParse.OptParser.make ~usage:
  "cmdopt -o [-q] [-d{0|1|2}] 文字列 [文字列 ...]" ()
and o = OptParse.StdOpt.store_true () 
and q = OptParse.StdOpt.store_true () 
and d = OptParse.StdOpt.int_option ();;
OptParse.OptParser.add ~short_name:'o' t o;
OptParse.OptParser.add ~short_name:'q' t q;
OptParse.OptParser.add ~short_name:'d' t d;;

let opts_form = format_of_string "\
  [オプション情報] \n\
  o(output) : %s \n\
  q(quote) : %s \n\
  d(debug) : %2s \n\n"

let opts_info () =
  if not (get o) then 
    (print_string "-o オプションがありません。\n"; exit 0) 
  else
    Printf.printf opts_form
     (switch (get o)) (switch (get q)) (debug (opt d))

let params_info l = 
  Printf.printf 
    "[パラメータ情報]\n指定数 : %d \n" (List.length l);
  ExtList.List.iteri (fun i s ->
    Printf.printf "%d : %s \n" (i+1) s) l;;

let _ = 
  if !Sys.interactive then () else
  let rest = OptParse.OptParser.parse_argv t in
  (opts_info (); params_info rest);;

[ OCaml ] [ download code ] ]

susu's comment on 文字列型日時ののN秒後時間取得

文字列型日時ののN秒後時間取得 (Nested Flatten)

#load "unix.cma";;

let scan_time s =
  Scanf.sscanf s "%4d%2d%2d%2d%2d%2d" (fun year mon day h m s ->
    { Unix.tm_sec = s;  tm_min = m;  tm_hour = h;
      tm_mday = day;  tm_mon = mon;  tm_year = year-1900;
      tm_wday = 0;  tm_yday = 0;  tm_isdst = false
    } ) ;;

let print_time { 
  tm_year = yy; tm_mon = mm; tm_mday = dd;
  tm_hour = h; tm_min = m; Unix.tm_sec = s } =
  Printf.printf "%d%02d%02d%02d%02d%02d" (yy+1900) mm dd h m s;;
  
let date_ex s sec =
  let {Unix.tm_sec = tsec} as tm = scan_time s in
  print_time (snd (Unix.mktime {tm with Unix.tm_sec=tsec+sec}));;

(* date_ex "20080827235925" 40;; *)

[ OCaml ] [ download code ] ]

gtaka555's comment on LL Golf Hole 7 - バイト数を読みやすくする

LL Golf Hole 7 - バイト数を読みやすくする (Nested Flatten)

OCamlで。

値は引数文字列, 1k = 1000, 小数点は 1 桁まで, 切捨てです。

短くして 247 bytes でした

let foo n =
  let u = " kMGT" in
  let l = String.length n in
  let idx = if (l mod 3) == 0 then (l / 3) - 1 else (l / 3) in
    Printf.printf "%s%s %cbytes\n"
      (String.sub n 0 (l - (idx * 3)))
      (if l > 3 then "." ^ (String.sub n (l-(idx*3)) 1) else "")
      u.[idx]
;;

(*
短く
let f n = let u = " kMGT" in let l = String.length n in let x = if (l mod 3) == 0 then (l / 3) - 1 else (l / 3) in Printf.printf "%s%s %cbytes\n" (String.sub n 0 (l - (x * 3))) (if l > 3 then "."^(String.sub n (l-(x*3)) 1) else "") u.[x];;
*)

foo "76543210";;

[ OCaml ] [ download code ] ]

gtaka555's comment on LL Golf Hole 8 - 横向きのピラミッドを作る

LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

OCaml で

let foo n =
  let s = String.make n '*' in
  let rec bar x =
    if x > n then ()
    else (
      print_string ((String.sub s 0 (n-(abs(x))))^"\n");
      bar (x + 1);
    )
  in
    bar (0 - n)
;;

foo 4;;

[ OCaml ] [ download code ] ]

komamitsu's comment on 必ず解ける迷路

必ず解ける迷路 (Nested Flatten)

osiireさんからブログ経由でアドバイスを頂いたのを皮切りに、色々無駄な処理が気になってきたので再度修正した自己満足第三弾。Array.iter等を使うように、などなど。

type field = Space | Wall

let x = int_of_string (Sys.argv.(1))
let y = int_of_string (Sys.argv.(2))

let rec repeate f x i n =
  if i < n then repeate f (f i x) (i + 1) n else x

let make_line v = Array.make (x * 2 - 1) v

let make_empty_line () = make_line Space

let make_filled_line () = make_line Wall

let print_line line =
  print_string "■";
  Array.iter (
    fun a -> if a = Wall then print_string "■" else print_string "　"
  ) line;
  print_endline "■"

type mode = Top | Normal

let make_maze mode lines =
  let way = match mode with Top -> 4 | Normal -> 3 in
  let rec make_wall pos =
    let (y, x) =
      match (Random.int way) with
      | 0 -> (1, pos + 1)
      | 1 -> (2, pos)
      | 2 -> (1, pos - 1)
      | 3 -> (0, pos)
      | _ -> failwith "invalid value" in
    if lines.(y).(x) = Wall
      then make_wall pos
      else (
        lines.(1).(pos) <- Wall;
        lines.(y).(x) <- Wall
      ) in
  Array.iteri (fun i a -> if i mod 2 = 1 then make_wall i) lines.(0)

let main () =
  let _ = Random.init (int_of_float (Unix.time ())) in
  let draw_maze pos last_line =
    let lines = [|last_line; make_empty_line (); make_empty_line ()|] in
    make_maze (if pos = 0 then Top else Normal) lines;
    print_line lines.(0);
    print_line lines.(1);
    lines.(2) in
  let filled_line = make_filled_line () in
  print_line filled_line;
  print_line (repeate draw_maze (make_empty_line ()) 0 y);
  print_line filled_line

let _ = main ()

[ OCaml ] [ download code ] ]