M.Hiroi's Home Page

Tcl/Tk GUI Programming

Tcl/Tk お気楽 GUI プログラミング実用編

[ Home | Tcl/Tk | Tcl/Tk入門 ]

●apply

% apply {{} {puts "oops!!"}}
oops!!
% apply {{x} {expr $x * $x}} 10
100
% apply {{x y} {expr $x + $y}} 1 2
3
% namespace eval Foo { variable x 10 y 20}
% apply {{} {variable x; variable y; puts "$x $y"} Foo}
10 20
% namespace eval Bar { variable x 100 y 200}
% apply {{} {variable x; variable y; puts "$x $y"} Bar}
100 200
% set x 1
1
% set y 2
2
% apply {{} {variable x; variable y; puts "$x $y"}}
1 2

% proc make_adder {x} {return "{y} {expr $x + \$y}"}
% set add10 [make_adder 10]
{y} {expr 10 + $y}
% apply $add10 100
110
% set add100 [make_adder 100]
{y} {expr 100 + $y}
% apply $add100 100
200

リスト : 高階関数

# マッピング
proc map {func xs} {
    set ys {}
    foreach x $xs {
        lappend ys [apply $func $x]
    }
    return $ys
}

# フィルター
proc filter {pred xs} {
    set ys {}
    foreach x $xs {
        if {[apply $pred $x]} {
            lappend ys $x
        }
    }
    return $ys
}

# 畳み込み
proc reduce {func a xs} {
    foreach x $xs {
        set a [apply $func $a $x]
    }
    return $a
}

% set zs {1 2 3 4 5 6 7 8}
1 2 3 4 5 6 7 8
% map {{x} {expr $x * $x}} $zs
1 4 9 16 25 36 49 64
% filter {{x} {expr $x % 2 == 0}} $zs
2 4 6 8
% reduce {{x y} {expr $x + $y}} 0 $zs
36

リスト : ボタンとラベルの使い方 (Windows では sjis で保存すること)

proc push_button {n} {
    global buffer
    set buffer 押したボタンは$nです
}

label .l -textvariable buffer
pack .l
foreach i {0 1 2 3} {
    button .b$i -text "button $i" -command "push_button $i"  
    pack .b$i -fill x 
}

リスト : apply 版

label .l -textvariable buffer
pack .l
foreach i {0 1 2 3} {
    button .b$i -text "button $i" \
           -command "apply {{} {global buffer; set buffer 押したボタンは$iです}}"
    pack .b$i -fill x 
}

●コルーチン

% coroutine foo apply {{} {yield "start"; yield 1; yield 2; yield 3; return "stop"}}
start
% foo
1
% foo
2
% foo
3
% foo
stop
% foo
invalid command name "foo"
% coroutine foo apply {{} {puts [yield "start"]; puts [yield 1]; puts [yield 2]; return "stop"}}
start
% foo 100
100
1
% foo 200
200
2
% foo 300
300
stop
% foo 400
invalid command name "foo"

リスト : コルーチンの簡単な使用例 (co1.tcl)

proc printcode {code} {
    yield
    while 1 {
        puts -nonewline $code 
        yield
    }
}

proc test_a {n} {
    coroutine co1 printcode "h"
    coroutine co2 printcode "e"
    coroutine co3 printcode "y"
    coroutine co4 printcode "!"
    coroutine co5 printcode " "
    while {$n > 0} {
        foreach i {1 2 3 4 5} {
            co$i
        }
        incr n -1
    }
    puts ""
}

# n から始まる整数列
proc integers {n} {
    yield
    while 1 {
        yield $n
        incr n
    }
}

# フィルター
proc sieve_filter {n src} {
    yield
    while 1 {
        set m [$src]
        if {$m % $n != 0} {
            yield $m
        }
    }
}

# エラトステネスの篩
proc sieve {x} {
    coroutine ints integers 2
    set nums ints
    while {$x > 0} {
        set n [$nums]
        puts -nonewline "$n "
        coroutine filter$n sieve_filter $n $nums
        set nums filter$n
        incr x -1
    }
    puts ""
}

% source co1.tcl
% test_a 5
hey! hey! hey! hey! hey!
% test_a 15
hey! hey! hey! hey! hey! hey! hey! hey! hey! hey! hey! hey! hey! hey! hey!
% sieve 25
2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97
% sieve 100
2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 
149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 
293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 
461 463 467 479 487 491 499 503 509 521 523 541

●イメージ (PNG)

リスト : 画像ローダー

# ファイルのロード
proc load_file {} {
    global image_data path_name
    # -filetypes に .png を追加
    set filename [tk_getOpenFile -initialdir $path_name \
                                 -filetypes {{{ImageFiles} {.png .gif .ppm}}}]
    if {$filename != ""} {
        set path_name [file dirname $filename]
        image delete image_data
        image create photo image_data -file $filename
        .l0 configure -image image_data
    }
}

# 画像表示用のラベル
set path_name ""
image create photo image_data -width 64 -height 64
label .l0 -image image_data
pack .l0

# メニューの設定
menu .m -type menubar
. configure -menu .m
.m add cascade -label "File" -under 0 -menu .m.m1
menu .m.m1 -tearoff no
.m.m1 add command -label "Open" -under 0 -command "load_file"
.m.m1 add separator
.m.m1 add command -label "Exit" -under 0 -command "exit"

ファイルの選択

PNG ファイル (ichimatu.png) の表示

●リスト操作 (2)

●tailcall

●パッケージ

●多倍長整数

リスト : 多倍長整数の簡単な例題 (sample.tcl)

# 階乗
proc fact {n} {
    if {$n == 0} {
        return 1
    } else {
        expr $n * [fact [expr $n - 1]]
    }
}

# フィボナッチ数
proc fibo {n} {
    set a 0
    set b 1
    while {$n > 0} {
        set c [expr $a + $b]
        set a $b
        set b $c
        incr n -1
    }
    return $a
}

# 組み合わせの数
proc combination {n r} {
    if {$n == $r || $r == 0} {
        return 1
    } else {
        expr [combination $n [expr $r - 1]] * ($n - $r + 1) / $r
    }
}

# カタラン数
proc catalan {n} {
    expr [combination [expr $n * 2] $n] / ($n + 1)
}

# モンモール数 (完全順列の総数)
proc montmort {n} {
    set a 0
    set b 1
    for {set i 1} {$i < $n} {incr i} {
        set c [expr ($i + 1) * ($a + $b)]
        set a $b
        set b $c
    }
    return $a
}

$ tclsh
% expr 2**32
4294967296
% expr 2**64
18446744073709551616
% expr 2**128
340282366920938463463374607431768211456

% expr 1 << 32
4294967296
% expr 1 << 64
18446744073709551616
% expr 1 << 128
340282366920938463463374607431768211456

% source sample.tcl
% fact 20
2432902008176640000
% fact 40
815915283247897734345611269596115894272000000000

% fibo 40
102334155
% fibo 100
354224848179261915075

% combination 40 20
137846528820
% combination 100 50
100891344545564193334812497256

% catalan 10
16796
% catalan 50
1978261657756160653623774456
% catalan 100
896519947090131496687170070074100632420837521538745909320

% montmort 10
1334961
% montmort 20
895014631192902121
% montmort 40
300158458444475693321518926221316715906770469041

●簡単なプログラム (ライフゲーム)

ライフゲームは 1970 年にイギリスの数学者コンウェイ氏が考案したシミュレーションゲームです。格子状に並んだマス (セル) で生命を表し、周りのセルの状態で生命が誕生したり死滅したりします。以下に規則を示します。

  1. 生命がいないセル
  2. 生命がいるセル

今回のゲームでは黄色の四角形で生きている生命を表しています。ゲームを停止しているとき、マウスの左クリックで生命を追加したり取り除くことができます。

生命をランダムに配置

途中経過

定常状態

●プログラムリスト

#
# lifegame.tcl : ライフゲーム
#
#                Copyright (C) 2019 Makoto Hiroi
#

# グローバル変数
set line 40
set column 60
set game_id ""
set buff ""
set generation 0
set cells  [dict create];  # セルを表す図形 ID を格納
set world1 [dict create];  # 0: 死, 1: 生
set world2 [dict create]

# ラベル
label .l0 -textvariable buff
pack .l0

# キャンバス
canvas .c0  -width [expr $column * 10] -height [expr $line * 10]
.c0 create rectangle 0 0 [expr $column * 10] [expr $line * 10] -fill darkgray -tags back
pack .c0

# 世代を進める
proc next_gen {name1 name2} {
  global line column cells
  upvar $name1 w1 $name2 w2
  for {set y 0} {$y < $line} {incr y} {
    for {set x 0} {$x < $column} {incr x} {
      set c 0
      # 生きているセルをカウント
      foreach d {{-1 -1} {0 -1} {1 -1} {-1 0} {1 0} {-1 1} {0 1} {1 1}} {
        set x1 [expr $x + [lindex $d 0]]
        set y1 [expr $y + [lindex $d 1]]
        if {0 <= $x1 && $x1 < $column && 0 <= $y1 && $y1 < $line} {
          incr c [dict get $w1 "$y1,$x1"]
        }
      }
      if {[dict get $w1 "$y,$x"] == 0} {
        if {$c == 3} {
          dict set w2 "$y,$x" 1;    # 誕生
          .c0 raise [dict get $cells "$y,$x"] back
        } else {
          dict set w2 "$y,$x" 0
        }
      } else {
        if {$c <= 1 || $c >= 4} {
          dict set w2 "$y,$x" 0;    # 過疎または過密
          .c0 lower [dict get $cells "$y,$x"] back
        } else {
          dict set w2 "$y,$x" 1;    # 存続
        }
      }
    }
  }
}

# セルの生成
proc make_cell {x y} {
  set x1 [expr $x * 10]
  set y1 [expr $y * 10]
  .c0 create rectangle $x1 $y1 [expr $x1 + 10] [expr $y1 + 10] -fill yellow -tags cell
}

for {set y 0} {$y < $line} {incr y} {
  for {set x 0} {$x < $column} {incr x} {
    dict set cells "$y,$x" [make_cell $x $y]
    dict set world1 "$y,$x" 0
    dict set world2 "$y,$x" 0
  }
}

# 乱数による初期化
proc init_game {} {
  global game_id line column world1 cells
  if {$game_id == ""} {
    for {set y 0} {$y < $line} {incr y} {
      for {set x 0} {$x < $column} {incr x} {
        if {[expr rand()] < 0.2} {
          dict set world1 "$y,$x" 1
          .c0 raise [dict get $cells "$y,$x"] back
        } else {
          dict set world1 "$y,$x" 0
          .c0 lower [dict get $cells "$y,$x"] back
        }
      }
    }
  }
}

# ゲームの進行を表示する
proc show_game {} {
  global generation buff game_id world1 world2
  if {$generation % 2 == 0} {
    next_gen world1 world2
  } else {
    next_gen world2 world1
  }
  incr generation
  set buff "Generation: $generation"
  set game_id [after 300 show_game]
}

# ゲームの開始
proc start_game {} {
  global game_id
  if {$game_id == ""} {
    show_game
  }
}

# ゲームの停止
proc stop_game {} {
  global game_id
  if {$game_id != ""} {
    after cancel $game_id
    set game_id ""
  }
}

# ゲームのクリア
proc clear_game {} {
  global game_id line column world1 generation buff
  if {$game_id == ""} {
    for {set y 0} {$y < $line} {incr y} {
      for {set x 0} {$x < $column} {incr x} {
        dict set world1 "$y,$x" 0
      }
    }
    .c0 lower cell back
    set generation 0
    set buff ""
  }
}

# マウスによる入力
proc click {x1 y1} {
  global game_id column line world1 cells
  if {$game_id == ""} {
    set x [expr ($x1 / 10) % $column]
    set y [expr ($y1 / 10) % $line]
    dict set world1 "$y,$x" [expr [dict get $world1 "$y,$x"] ^ 1]
    if {[dict get $world1 "$y,$x"] > 0} {
      .c0 raise [dict get $cells "$y,$x"] back
    } else {
      .c0 lower [dict get $cells "$y,$x"] back
    }
  }
}

# バインディング
.c0 bind back <Button-1> { click %x %y }
.c0 bind cell <Button-1> { click %x %y }

# メニューバー
menu .m -type menubar
. configure -menu .m
.m add command -label Start -underline 0 -command start_game
.m add command -label Stop  -underline 0 -command stop_game
.m add command -label Clear -underline 0 -command clear_game
.m add command -label Rand  -underline 0 -command init_game

# 初期化
clear_game
Copyright (C) 2019 Makoto Hiroi
All rights reserved.
[ Home | Tcl/Tk | Tcl/Tk入門 ]