ぐいぐい

コンパイルのやり方とか、ファンクターとか、オブジェクトとか、ラベル付き引数とか、オプション引数とか、多相ヴァリアントとかいろいろやったけど、全部すっ飛ばしていきなりGUI。
お金を預けたり引き出したりする簡単なプログラム。

open Tk
open Printf

(* 残高操作 *)
let balance = ref 0
let add_balance x = balance := !balance + x

(* ウィジェットを作る *)
let top = openTk ()

let tv_balance = Textvariable.create ()
let label1 = Label.create top ~textvariable: tv_balance ~relief: `Raised

let print_balance tv =
  let s = sprintf "残高は %8d円 です" !balance in
  Textvariable.set tv s;
  Label.configure label1
    ~foreground: (if !balance < 0 then `Red else `Black)

let mid_frame = Frame.create top
let entry = Entry.create mid_frame
and label2 = Label.create mid_frame ~text: "円"
and rb_frame = Frame.create mid_frame

let tv_button = Textvariable.create ()
let radiobuttons = 
  List.map
    (fun (text, value) ->
      Radiobutton.create rb_frame ~text ~value ~variable: tv_button)
    [("を預金する", "Deposit"); ("を引き出す", "Withdraw")]

let bot_frame = Frame.create top
let lstbox = Listbox.create bot_frame
let sclbar = Scrollbar.create bot_frame ~command: (Listbox.yview lstbox)
let () = Listbox.configure lstbox ~yscrollcommand: (Scrollbar.set sclbar)

let action entry tv_but tv_bal () =
  let y = int_of_string (Entry.get entry) in
  match Textvariable.get tv_but with
    "Deposit" -> add_balance y;
      Listbox.insert lstbox ~index: `End ~texts: [sprintf "%8d円 預けました。" y];
      print_balance tv_bal
  | "Withdraw" -> add_balance (-y);
      Listbox.insert lstbox ~index: `End ~texts: [sprintf "%8d円 引き出ました。" y];
      print_balance tv_bal
  | _ -> failwith "Cannnot happen"

let button = 
  Button.create mid_frame
    ~text: "実行" ~command: (action entry tv_button tv_balance)

(* ウィジェット配置と初期化 *)
let () = 
  pack radiobuttons ~side: `Top;
  pack [coe entry; coe label2; coe rb_frame; coe button] ~side: `Left;
  pack [coe label1; coe mid_frame; coe bot_frame] ~side: `Top;
  pack [coe bot_frame] ~side: `Top ~fill: `Both ~expand: true;
  pack [coe lstbox; coe sclbar] ~side: `Left ~fill: `Y;
  pack [coe lstbox] ~fill: `Both ~expand: true;
  print_balance tv_balance;
  mainLoop ()