DouKaku?beta

Language detail: OCaml

Coverage: 61.93%
number of '+' ratings
 contribution for coverage

Unsolved challenges

show all

codes

Feed

Used modules

next >>

π (Nested Flatten)

OCamlにはpiは標準ではありませんが、arccosがプリミティブで用意されています。

1
let pi = acos (-1.)
ACLの制御 (Nested Flatten) 
1
2
3
4
let file = Sys.argv.(1) in 
let f = try open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o600 file
with Sys_error msg -> failwith ("Couldn't write to " ^ msg) in 
output_string f "OCaml\n";close_out f;;
ウィンドウの表示 (Nested Flatten) 
1
2
3
4
5
6
let main () =
  let window = GWindow.window ~title:"こんにちは、GUI！" ~width:400 ~height:300 () in
  window#show ();
  GMain.Main.main ()

let _ = main ()
シードを固定した乱数 (Nested Flatten)
こういうのでいいのだろうか？ 
1
let fixed_seed_rand num = Random.init 10; Random.float num;;
バイナリクロック (Nested Flatten) 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
let itobin i =
  if i == 0 then [0]
  else
    let rec itob l i = match i with
        0 -> 1::l
      | 1 -> 1::l
      | _ -> itob ((i mod 2)::l) (i/2)
    in itob [] i
;;

let rec padding l = 
  if (List.length l) < 6 then padding (0::l)
  else l
;;

let format_print l = 
  let d = [|"□";"■"|] in 
  let rec square_print l = match l with
    [] -> print_string "\n"
  | s::r -> print_string d.(s);
      square_print r
    in square_print l
;;


let () = 
  let t = Unix.localtime(Unix.time()) in
  format_print (padding (itobin t.Unix.tm_hour));
  format_print (padding (itobin t.Unix.tm_min))
;;
総当たり戦の日程作成 (Nested Flatten)
チーム数が奇数の場合にも対応しています。
チーム数が奇数の場合、各チームが1日ずつ休みをとることで日程を調整します。 
1
2
3
4
5
6
7
8
let createSchedule n =
    let rotate = function t1::t2::ts -> t1::ts @ [t2]
    let createMatchs ts =
        Seq.zip (Seq.take (List.length ts / 2) ts) (List.rev ts)
        |> Seq.filter (fun (x, y) -> x <= n && y <= n) |> Seq.to_list
    (1, [1..(n + n % 2)]) |> Seq.unfold (fun (i, ts) ->
        if i < n + n % 2 then Some(createMatchs ts, (i + 1, rotate ts)) else None)
    |> Seq.to_list
ラングトンのアリの描画 (Nested Flatten)
F# 1.9.6.16 で作成しました。
初期状態の背景色を白黒選択可能にしました。
アリの初期状態の向きはランダムにしています。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
open System
open System.Windows.Forms
open System.Drawing

let size = 300
let (white, black) = (-1, 1)
let dirTable = [|(1, 0); (0, 1); (-1, 0); (0, -1)|]
let dirTextTable = [|"右"; "下"; "左"; "上"|]

type Langton'sAntForm() as this =
    inherit Form()
    [<DefaultValue>]
    val mutable ant : int -> int[,] -> Async<unit>
    let bitmap = new Bitmap(size, size)
    let picture = new PictureBox(Image = bitmap, Size = new Size(size, size), Location = new Point(0, 30))
    let button = new Button(Size = new Size(50, 30), Location = new Point(0, 0), Text = "Start")
    let checkbox = new CheckBox(Size = new Size(70, 30), Location = new Point(60, 0), Text = "黒背景")
    let labelDir = new Label(Size = new Size(80, 30), Location = new Point(140, 0), TextAlign = ContentAlignment.MiddleLeft)
    let labelStep = new Label(Size = new Size(60, 30), Location = new Point(230, 0), TextAlign = ContentAlignment.MiddleLeft)
    do this.Controls.AddRange([|(picture :> Control); (button :> Control); (checkbox :> Control); (labelDir :> Control); (labelStep :> Control)|])
    do this.Text <- "ラングトンのアリ"
    do this.ClientSize <- new Size(size, size + 30)
    do this.FormBorderStyle <- FormBorderStyle.Fixed3D
    do this.MaximizeBox <- false
    do button.Click.Add(fun _ ->
        let dir = (new Random()).Next(4)
        labelDir.Text <- "初期方向：" ^ dirTextTable.[dir]
        let (place, color) = if checkbox.Checked then (black, Color.Black) else (white, Color.White)
        [for x in 0..(size - 1) -> [for y in 0..(size - 1) -> (x, y)]] |> List.concat
        |> List.iter(fun (x, y) -> bitmap.SetPixel(x, y, color))
        Array2D.create size size place |> this.Ant dir |> Async.Start
        button.Enabled <- false)
    
    member this.Ant with get() = this.ant and set(value) = this.ant <- value
    member this.Print (x, y) place step =
        try
            if this.InvokeRequired then
                this.Invoke(new MethodInvoker(fun () ->
                    bitmap.SetPixel(x, y, if place = white then Color.White else Color.Black)
                    labelStep.Text <- string step
                    this.Refresh()))
                |> ignore
        with
        | :? ObjectDisposedException -> ()

let rec loop step (x, y) dir (field : int[,]) (form : Langton'sAntForm) =
    let rotate dir place = (dir + place + 4) % 4
    let turnover = ( * ) -1
    let move (x, y) dir =
        let (dx, dy) = dirTable.[dir] in (x + dx, y + dy)
    let (|InField|OutOfField|) (x, y) =
        if 0 <= x && x < size && 0 <= y && y < size then InField else OutOfField

    match (x, y) with
    | OutOfField -> ()
    | InField ->
        let newDir = rotate dir field.[x, y]
        field.[x, y] <- turnover field.[x, y]
        form.Print (x, y) field.[x, y] step
        loop (step + 1) (move (x, y) newDir) newDir field form

[<STAThread()>]
do
    use form = new Langton'sAntForm()
    form.Ant <- fun dir field -> async { loop 1 (size / 2, size / 2) dir field form }
    Application.EnableVisualStyles()
    Application.Run(form) |> ignore
リングノードベンチマーク (Nested Flatten)
MailboxProcessor を使用して実装しました。
m = 1000 で固定、n = 100, 1000, 10000 の場合のベンチマークをとっています。

環境：Core2Quad 2.5GHz, Windows Vista 32bit

> benchmark 100 1000 |> printfn "%d ms";;
825 ms
val it : unit = ()
> benchmark 1000 1000 |> printfn "%d ms";;
7770 ms
val it : unit = ()
> benchmark 10000 1000 |> printfn "%d ms";;
113861 ms
val it : unit = () 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
#light

open System
open System.Diagnostics
open System.Threading

type Node(next, m, eventwait : AutoResetEvent) =
    let mailbox =
        MailboxProcessor.Start(fun inbox ->
            let rec loop l =
                async {
                    let! (nodes : Node[]) = inbox.Receive()
                    nodes.[next].Post(nodes)
                    if l < m then
                        return! loop (l + 1)
                    else
                        eventwait.Set() |> ignore
                        return ()
                }
            loop 0
        )
    member this.Post(msg) = mailbox.Post(msg)

let benchmark n m =
    let eventwait = new AutoResetEvent(false)
    let nodes = [|for i in 1..n -> new Node(i % n, m, eventwait)|]
    let stopwatch = Stopwatch.StartNew()
    nodes.[0].Post(nodes)
    eventwait.WaitOne() |> ignore
    stopwatch.Stop()
    stopwatch.ElapsedMilliseconds
例外処理 (Nested Flatten)
F#ではtry～withで例外処理を行えます。
with部分で例外の種類を特定するのにパターンマッチを使用する点が特徴です。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
#light

open System

exception Original of string * string    // F#例外の定義

type Example() =
    member this.Func() =
        Original("ユーザー定義例外", "例外発生") |> raise
    interface IDisposable with
        member this.Dispose() =
            printfn "資源解放"

try
    use ex = new Example()
    ex.Func()
with
    | :? NullReferenceException as e ->  // .NET例外の捕捉
        printfn "ぬるぽ　%s" e.Message
        rethrow()
    | Original(name, msg) ->             // F#例外の捕捉
        printfn "例外名：%s　メッセージ：%s" name msg
17歳教 (Nested Flatten)
17歳未満の誕生日を入力すると怒られます。
23歳教にも対応するため、プログラム起動時のパラメータで年齢を指定できるようにしました。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#light

open System

let getAge age (birthday : DateTime) =
    let today = DateTime.Today
    if birthday > today then failwith "まだ産まれていません"
    let limitday = birthday.AddYears(age)
    if limitday > today then failwith "若すぎます！"
    let days = (today - limitday).Days
    let months = (today.Year - limitday.Year) * 12 + (today.Month - limitday.Month)
                 - (if today.Day < limitday.Day then 1 else 0)
    let monthdays = (today - limitday.AddMonths(months)).Days
    (age, days, months, monthdays)

let printAge (age, days, months, monthdays) =
    let toStr n unit =
        if n = 0 then "" else sprintf "と%d%s" n unit
    printfn "%d歳%s" age (toStr days "日")
    printfn "%d歳%s%s" age (toStr months "ヶ月") (toStr monthdays "日")

let age =
    let defaultAge = 17
    let args = Environment.GetCommandLineArgs()
    if args.Length < 2 then defaultAge
    else match Int32.TryParse(args.[1]) with
         | true, age' -> age'
         | false, _ -> defaultAge
printf "誕生日を入力 >"
try
    match DateTime.TryParse(Console.ReadLine()) with
    | true, date -> getAge age date |> printAge
    | false, _ -> ()
with
    | Failure msg -> printfn "%s" msg
テキスト行の正規化 (Nested Flatten)
単純な実装です。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
#light

let pad ch (text : string) =
    let lines = text.Split([|'\n'|])
    let maxLength = lines |> Array.map String.length |> Array.max
    let paddedLines = lines.[0..(lines.Length - 2)]
                      |> Array.map (fun x -> x.PadRight(maxLength, ch))
    String.concat "\n" paddedLines ^ "\n"

"○○○○\n○○○○○○○\n\n○○○○○\n" |> pad '☆' |> printfn "%s"
loan patternのサンプル (Nested Flatten)
loan pattern 用の汎用関数です。
引数なしのコンストラクタを持ち、IDisposableインターフェースを実装するクラスに対して使用可能です。

＜実行結果＞
処理実行
破棄 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
#light

open System

let loan (f : 'T -> 'U when 'T : (new : unit -> 'T) and 'T :> IDisposable) =
    use x = new 'T() in f x

type Example() =
    member this.Method() = printfn "処理実行"
    interface IDisposable with
        member this.Dispose() = printfn "破棄"

loan (fun (x : Example) -> x.Method())
IPv4アドレスのマスクの変換 (Nested Flatten)

すみません、昨日無駄にNativeintを使ったあげく、末尾再帰最適化されないコードを書いてしまいました。同じアルゴリズムをより正しく実装したものがこっちです。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#load "str.cma"

let print_string_nl v = print_string (v ^ "\n")
let print_int_nl v = print_string_nl (string_of_int v)

let netmask_num_of addr =
    let onbits_of byte = 
        let rec loop ptr v =
            if ptr < 0 || byte land (1 lsl ptr) = 0 then v
            else loop (ptr - 1) (v + 1)
        in loop 7 0
    in
    let addrs = List.map int_of_string (Str.split (Str.regexp "\\.") addr) in
    List.fold_left (fun a b -> a + (onbits_of b)) 0 addrs 
;;
print_int_nl (netmask_num_of "255.255.255.0");;
print_int_nl (netmask_num_of "255.255.255.128");;
print_int_nl (netmask_num_of "255.255.255.255");;

let netmask_str_of num =
    let rec byteloop num n v =
        if n = 0 then v
        else
            let rec bitloop num b v =
                if num = 0 or b < 0 then v
                else bitloop (num - 1) (b - 1) ((1 lsl b) lor v)
            in byteloop (num - 8) (n - 1) (v @ [string_of_int (bitloop num 7 0)])
    in String.concat "." (byteloop num 4 [])
;;
print_string_nl (netmask_str_of 24);;
print_string_nl (netmask_str_of 25);;
print_string_nl (netmask_str_of 32);;

F#で、
実行例
> maskstr2num "255.255.255.0";;
val it : int = 24
> maskstr2num "255.255.255.128";;
val it : int = 25
> maskstr2num "255.255.255.255";;
val it : int = 32
> num2maskstr 24;;
val it : string = "255.255.255.0"
> num2maskstr 25;;
val it : string = "255.255.255.128"
> num2maskstr 32;;
val it : string = "255.255.255.255"

see: ビットを数える・探すアルゴリズム 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
let bitcount bits:int =
  let bits = (bits &&& 0x55555555) + (bits >>> 1 &&& 0x55555555)
  let bits = (bits &&& 0x33333333) + (bits >>> 2 &&& 0x33333333)
  let bits = (bits &&& 0x0f0f0f0f) + (bits >>> 4 &&& 0x0f0f0f0f)
  let bits = (bits &&& 0x00ff00ff) + (bits >>> 8 &&& 0x00ff00ff) in 
      (bits &&& 0x0000ffff) + (bits >>>16 &&& 0x0000ffff)

let maskstr2num (mask:string) =
  bitcount  <| Seq.fold ( fun a b -> a * 256 + int b ) 0 (mask.Split('.'))

let num2maskstr (num:int) =
  let unum = uint32 (2.0 ** (float num))-1u <<< (32-num)
  System.String.Join(".", [|for i=3 downto 0 do yield ((unum &&& (0xFFu <<< i*8) >>> i*8).ToString()) |])

正変換は単に立っているビットの数を数えているだけ、逆変換は頭からビットを立たせているだけです。それだけしか出来ていないのに、ここで息切れしてしまいました。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#load "str.cma"

let ni0 = Nativeint.zero;;
let ni1 = Nativeint.one;;
let (<<@) = Nativeint.shift_left;;
let (&@) = Nativeint.logand;;
let (|@) = Nativeint.logor;;

let netmask_num_of addr =
    let onbits_of byte = 
        let rec loop ptr =
            if ptr < 0 then 0 else
            let checker = ni1 <<@ ptr in
            if byte &@ checker = ni0 then 0 else
                1 + (loop (ptr - 1))
        in
            loop 7
    in
        let addrs = List.map Nativeint.of_string
            (Str.split (Str.regexp "\\.") addr) in
        List.fold_left (fun a b -> a + (onbits_of b)) 0 addrs 
;;
print_string ((string_of_int (
    netmask_num_of "255.255.255.0")) ^ "\n");;
print_string ((string_of_int (
    netmask_num_of "255.255.255.128")) ^ "\n");;
print_string ((string_of_int (
    netmask_num_of "255.255.255.255")) ^ "\n");;

let netmask_str_of num =
    let rec byteloop num n =
        if n = 0 then [] else
        let rec bitloop num b =
            if num = 0 or b < 0 then ni0 else
            (ni1 <<@ b) |@ (bitloop (num - 1) (b - 1))
        in
            [Nativeint.to_string (bitloop num 7)] @
                (byteloop (num - 8) (n - 1))
    in
        String.concat "." (byteloop num 4)
;;
print_string ((netmask_str_of 24) ^ "\n");;
print_string ((netmask_str_of 25) ^ "\n");;
print_string ((netmask_str_of 32) ^ "\n");;
手作業Grep (Nested Flatten) 
F# で、作ってみました。
（FSharpSamplesのEditor.fsで、RichTextBoxをListBox に変更したもの）
コンパイルは、
fsc HandGrep.fs -g
--target:winexe にしてしまうと、stdin は、取れてもstdout が、出力されなくなるので、注意。
空行は無視される
使用例：
>dir /B | HandGrep
handgrep.exe
handgrep.fs
File メニューからQuit した場合stdoutに書き出す。
×（閉じる）ボタンで終了すると、出力はされない。
File メニューからファイルの読み込みもできる
パイプなど標準入力を指定しないで起動した場合は、コンソールから入力するかしないですぐにＣＴＲＬ＋Ｚ
選択は、
ＣＴＲＬ＋マウスクリック
または、
ＳＨＩＦＴ＋マウスクリック
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
#light

open System
open System.IO  
open System.Windows.Forms

let form = new Form(Width= 400, Height = 300, Visible = true, Text = "HandGrep", Menu = new MainMenu())

// menu bar and menus 
let mFile = form.Menu.MenuItems.Add("&File")
let mHelp = form.Menu.MenuItems.Add("&Help")

// menu items 
let miOpen  = new MenuItem("&Open...")
let miQuit  = new MenuItem("&Quit")
let miAbout = new MenuItem("&About...")

mFile.MenuItems.Add(miOpen)  |> ignore
mFile.MenuItems.Add(miQuit)  |> ignore
mHelp.MenuItems.Add(miAbout) |> ignore

// ListBox
let listB = new ListBox(Dock=DockStyle.Fill)
listB.SelectionMode <- SelectionMode.MultiExtended

let in_ar = stdin.ReadToEnd().Split([|"\r\n"|],StringSplitOptions.RemoveEmptyEntries)
for s in in_ar do
    listB.Items.Add(s) |> ignore //drop index

form.Controls.Add(listB)

// filename state 
let mutable filename = ""
let SetFilename f  = filename <- f; form.Text <- "HandGrep - " ^ f

SetFilename "stdin"

// ReadFile dialog 
let ReadFile () =
    let d = new OpenFileDialog() 
    d.Filter <- "text files *.txt|*.txt|All files *.*|*.*";
    d.FilterIndex <- 2;
    if d.ShowDialog() = DialogResult.OK then
        let str  = new StreamReader(d.FileName)
        let text = str.ReadToEnd ()
        Some (d.FileName,text)
    else
        None


// Read in File 
let opLoadText _ = 
    match ReadFile () with
    | Some (file,text) -> 
        SetFilename file
        listB.Items.Clear()
        for s in text.Split([|"\r\n"|],StringSplitOptions.RemoveEmptyEntries) do
           listB.Items.Add(s) |> ignore //drop index
    | None -> ()


let opAbout _ = 
    MessageBox.Show("Selection StdIn","About HandGrep") |> ignore

let opExitForm _ =
    for item in listB.SelectedItems do
        stdout.WriteLine(string item)
    form.Close ()

// callbacks 
let _ = miOpen.Click.Add(opLoadText)
let _ = miQuit.Click.Add(opExitForm)
let _ = miAbout.Click.Add(opAbout)

[<STAThread()>]    
do Application.Run(form)
自分自身を表示する (Nested Flatten)
F# Interactive 上で実行した場合に要件を満たすコードです。
最後の「val it : unit = ()」を削除すると、Visual Studio 上で実行した場合に要件を満たすコードとなります。 
1
let s="let s=%O%s%O in printf (new PrintfFormat<char->string->char->unit,_,_,_>(s)) (char 34) s (char 34);;//" in printf (new PrintfFormat<char->string->char->unit,_,_,_>(s)) (char 34) s (char 34);;//val it : unit = ()
キッチンタイマー (Nested Flatten)
GUIウィンドウ上に、測定時間の入力ボックス・残り時間の表示部・タイマーのスタートボタンを配置しています。
入力ボックスには「分：秒」または「秒」での指定が可能です。
測定可能範囲は0:01～59:59で、範囲外の時間や不正な値を入力をするとエラーアイコンが表示されます。 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
#light

open System
open System.Windows.Forms
open System.Drawing

let label1 = new Label(Location = new Point(10, 12), AutoSize = true, Text = "測定時間")
let textBoxTime = new TextBox(Location = new Point(100, 10), Width = 50)
let label2 = new Label(Location = new Point(10, 40), AutoSize = true, Text = "残り時間")
let labelRest = new Label(Location = new Point(100, 40), AutoSize = true, Text = "")
let buttonStart = new Button(Location = new Point(10, 80), AutoSize = true, Text = "スタート")
let errorProvider = new ErrorProvider(BlinkStyle = ErrorBlinkStyle.BlinkIfDifferentError)
let timer = new Timer(Interval = 1000)
let rest = new TimeSpan() |> ref
let printRest (rest : TimeSpan) = labelRest.Text <- sprintf "%d:%02d" rest.Minutes rest.Seconds
buttonStart.Click.Add (fun _ ->
    match Text.RegularExpressions.Regex.Match(textBoxTime.Text, @"^((\d+):)?(\d+)$") with
    | m when not m.Success ->
        errorProvider.SetError(textBoxTime, "秒 または 分:秒 で指定してください")
    | m ->
        let min = if m.Groups.[1].Success then int m.Groups.[2].Value else 0
        match new TimeSpan(0, min, int m.Groups.[3].Value) with
        | rest' when rest'.TotalSeconds = 0. ->
            errorProvider.SetError(textBoxTime, "1秒以上を指定してください")
        | rest' when rest'.TotalHours >= 1. ->
            errorProvider.SetError(textBoxTime, "1時間未満を指定してください")
        | rest' ->
            errorProvider.SetError(textBoxTime, "")
            printRest rest'
            rest := rest'
            timer.Start())
timer.Tick.Add (fun _ ->
    rest := !rest - new TimeSpan(0, 0, 1)
    printRest !rest
    if (!rest).TotalSeconds = 0. then
        timer.Stop()
        Media.SystemSounds.Asterisk.Play())
let form = new Form(Text = "キッチンタイマー", Size = new Size(200, 160), AcceptButton = buttonStart)
[|(label1 :> Control); (textBoxTime :> Control); (label2 :> Control); (labelRest :> Control); (buttonStart :> Control)|]
|> form.Controls.AddRange
form.ShowDialog() |> ignore
16進数から10進数の変換 (Nested Flatten) 
F# で、Math.BigInt を使って桁の制限をなくしたバージョン
実行例：
> hex2dec "0x12437308CCB6";;
val it : Math.BigInt = 20080902065334I
> hex2dec "0x2C9C1227FC6520B";;
val it : Math.BigInt = 200904012311450123I

1
2
3
4
5
6
7
8
#light

let hex2dec (s:string) =
    let hs = s.[2..] //先頭の0x を取り除く
    let intToBigInt (x:int) = Math.BigInt(x)
    let bs = 16I
    let times_base x y = x * bs + y
    Seq.fold times_base 0I <| Seq.map (intToBigInt << int << (^) "0x" << string) hs

1
2
let [|hex_string|] = Sys.argv;;
print_endline (Int64.to_string (Int64.of_string hex_string));;
next >>

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]