Tcl/Tk で一定間隔で何かを処理させようと思ったときに after コマンドってどうやって使ったっけ？といつもマニュアルを見て考え込むので、備忘録として簡単なスクリプトにまとめました。今回は短くまとめることにこだわっています。
proc every {ms body} {eval $body; after $ms [info level 0]}
pack [label .l -bg white -textvariable now]
every 1000 {set ::now [clock format [clock seconds] -format %H:%M:%S]}
$ tclsh
% lassign [list 1 2 3] a b c
% puts $a
1
% puts $b
2
% puts $c
3
% exit
$ perl
($a, $b, $c) = (1, 2, 3);
print $a, "\n";
print $b, "\n";
print $c, "\n";
^D1
2
3
$
$ tclsh
% set z [list 1 2 3]
1 2 3
% set a [lindex $z 0]
1
% set b [lindex $z 1]
2
% set c [lindex $z 2]
3
% exit
$
$ tclsh
% foreach {a b c} [list 1 2 3] {}
% puts $a
1
% puts $b
2
% puts $c
3
% exit
$
chan は、Tcl 8.5 で追加されたコマンドです。チャネルを操作するコマンドで、従来の open や socket コマンドと同じことが出来るだけでなく、chan create コマンドでチャネルを独自に定義することもできます。
# -----------------------------------------------------------------------------
# NAMESPASE textOut
# -----------------------------------------------------------------------------
namespace eval textOut {
variable subCmds [list initialize finalize watch write]
variable m; # pathName of text widget to display message
namespace ensemble create -subcommands $subCmds
namespace export regist
# initialize
proc initialize {channelId mode} {
variable subCmds
return $subCmds
}
# finalize
proc finalize {channelId} {
# NOP
}
# watch
proc watch {channelId eventspec} {
# NOP
}
# write
proc write {channelId data} {
variable m
set msgout [encoding convertfrom [encoding system] $data]
$m configure -state normal
$m insert end $msgout
$m see end
$m configure -state disable
update
return [string length $data]
}
# regist
# The namespace specific command to remember pathName
proc regist {pathName} {
variable m
if {![winfo exists $pathName]} {
error "$pathName does not exist."
}
if {[winfo class $pathName] ne "Text"} {
error "$pathName is not text widget."
}
set m $pathName
$m configure -state disable
return $m
}
}
$ tclsh
% package require Tk
8.5.6
% pack [text .t]
% source textOut.tcl
% textOut::regist .t
.t
% set out [chan create write textOut]
rc0
% chan configure $out -buffering line
% puts $out "これは出力テストです。"
%
namespace ensemble（アンサンブル）は Tcl 8.5 で加わった namespace のサブコマンドです。
namespace eval test {
namespace ensemble create -subcommands [list abcd efgh]
proc abcd {} {
puts "-- subcommand 'abcd'! --"
}
proc efgh {} {
puts "-- subcommand 'efgh'! --"
}
proc ijkl {} {
puts "-- command 'ijkl' in namespace test --"
}
}
$ tclsh
% source test.tcl
% test
wrong # args: should be "test subcommand ?argument ...?"
% test abcd
-- subcommand 'abcd'! --
% test efgh
-- subcommand 'efgh'! --
% test ijkl
unknown or ambiguous subcommand "ijkl": must be abcd, or efgh
% test::ijkl
-- command 'ijkl' in namespace test --
namespace eval sombrero {
namespace export *
variable DX 640
variable DY 400
variable SOX [expr $DX / 2 - 1]
variable SOY [expr $DY / 2 - 1]
variable MAX [lrepeat $DX -1]
variable MIN [lrepeat $DX $DY]
variable Pi 3.1415926535
proc getWidth {} {
variable DX
return $DX
}
proc getHeight {} {
variable DY
return $DY
}
proc getRad {x} {
variable Pi
return [expr $x * $Pi / 180.0]
}
proc initVal {x y z} {
variable sx; variable sy; variable sz
variable cx; variable cy; variable cz
set x [getRad $x]; set y [getRad $y]; set z [getRad $z]
set sx [expr sin($x)]; set sy [expr sin($y)]; set sz [expr sin($z)]
set cx [expr cos($x)]; set cy [expr cos($y)]; set cz [expr cos($z)]
return
}
proc rotate {x y z} {
variable sx; variable sy; variable sz
variable cx; variable cy; variable cz
set x1 $x
set y1 [expr $y * $cx - $z * $sx]
set z1 [expr $y * $sx + $z * $cx]
set x2 [expr $x1 * $cy + $z1 * $sy]
set y2 $y1
set z2 [expr -$x1 * $sy + $z1 * $cy]
set x3 [expr $x2 * $cz - $y2 * $sz]
set y3 [expr $x2 * $sz + $y2 * $cz]
set z3 $z2
return [list $x3 $y3 $z3]
}
proc loop {a b c} {
if {$c > 0} {
return [expr $a <= $b]
} else {
return [expr $a >= $b]
}
}
proc func {x z} {
variable Pi
set l [expr hypot($x, $z)]
return [expr 50 * cos($Pi * $l / 100) + 5 * sin($Pi * $l / 25)]
}
proc draw {w x y} {
variable SOX; variable SOY
variable MAX; variable MIN
variable ix0; variable iy0
variable lsw
set ix [expr int($SOX + $x)]; set iy [expr int($SOY - $y)]
if {$lsw == 1} {
set lsw 0
set ix0 $ix; set iy0 $iy
}
if {$iy > [lindex $MAX $ix]} {
lset MAX $ix $iy
$w create line $ix0 $iy0 $ix $iy
}
if {$iy < [lindex $MIN $ix]} {
lset MIN $ix $iy
$w create line $ix0 $iy0 $ix $iy
}
set ix0 $ix; set iy0 $iy
return
}
proc main {w rx ry rz} {
variable DY
variable lsw
initVal $rx $ry $rz
set retList [rotate 0.0 0.0 [expr -$DY / 2]]
set za [lindex $retList 2]
set retList [rotate 0.0 0.0 [expr $DY / 2]]
set zb [lindex $retList 2]
set zz1 [expr -$DY / 2]; set zz2 [expr $DY / 2]; set stz 5
if {$za > $zb} {set zz1 -$zz1; set zz2 -$zz2; set ztz -$stz}
set xx1 [expr -$DY / 2]; set xx2 [expr $DY / 2]; set stx 1
for {set z $zz1} {[loop $z $zz2 $stz]} {incr z $stz} {
set lsw 1
for {set x $xx1} {[loop $x $xx2 $stx]} {incr x $stx} {
set dataList [rotate $x [func $x $z] $z]
set xa [lindex $dataList 0]
set ya [lindex $dataList 1]
draw $w $xa $ya
}
}
}
}
namespace import sombrero::*
# ------------------------------------------------------------------------------
# MAIN
# ------------------------------------------------------------------------------
wm title . "sombrero"
set w [canvas .can -width [getWidth] -height [getHeight]]
pack $w
main $w -45 20 0
# ---
# PROGRAM END
Order #: XXX-XXXXXXX-XXXXXXX
Shipping Method: Expedited International Shipping
Shipping Preference: Group my items into as few shipments as possible
Subtotal of Items: $42.70
Shipping & Handling: $13.98
------
Total for this Order: $56.68
Delivery estimate: June 18, 2009 - June 30, 2009
Shipping estimate for these items: June 8, 2009
1 "Tcl and the Tk Toolkit (2nd Edition) (Addison-Wesley Professional Computing Series)"
John K. Ousterhout; Paperback; $42.70
Sold by: Amazon.com, LLC
package require パッケージ名 ?バージョン番号?
$ tclsh
% puts $auto_path
/usr/share/tcl8.5 /usr/lib/tcl8.5 /usr/lib/tk8.5
%
$ tclsh8.6
% puts $auto_path
/home/bitwalk/lib/tcl8.6 /home/bitwalk/lib
%
export TCLPKG=$HOME/tclpkg
setenv TCLPKG $HOME/tclpkg
$ tclsh8.6
% parray env
env(COLORTERM) = gnome-terminal
env(CVSROOT) = :ext:bitwalk@mingw-cross.cvs.sourceforge.net:/cvs...
env(CVS_RSH) = ssh
（中略）
env(TCLPKG) = /home/bitwalk/tclpkg
env(TERM) = xterm
env(USER) = bitwalk
env(USERNAME) = bitwalk
env(WINDOWID) = 48240455
（中略）
%
$ mkdir ~/tclpkg
$ mkdir ~/tclpkg/Draw
# ----------------------------------------------------------------------------
# 拡張パッケージ Draw
# ----------------------------------------------------------------------------
package provide Draw 1.0
package require Tk;
package require TclOO; # ビルトインパッケージなので省略可
namespace import oo::*
# ----------------------------------------------------------------------------
# クラス Draw
# ----------------------------------------------------------------------------
class create Draw {
# ------------------------------------------------------------------------
# コンストラクタ
# ------------------------------------------------------------------------
constructor {} {
my variable conf
set conf(color) black
set conf(width) 1
}
# ------------------------------------------------------------------------
# 設定
# ------------------------------------------------------------------------
method init {color {width 1}} {
my variable conf
set conf(color) $color
set conf(width) $width
return
}
# ------------------------------------------------------------------------
# 描画起点の座標を取得
# ------------------------------------------------------------------------
method first {x y} {
my variable conf
set conf(x0) $x
set conf(y0) $y
return
}
# ------------------------------------------------------------------------
# 線を描画
# ------------------------------------------------------------------------
method line {w x y} {
my variable conf
$w create line $conf(x0) $conf(y0) $x $y \
-fill $conf(color) \
-width $conf(width) \
-tags mLine
my first $x $y
return
}
# ------------------------------------------------------------------------
# 線を消去
# ------------------------------------------------------------------------
method erase {w} {
$w delete mLine
return
}
}
# ---
# Draw.tcl
$ cd ~/tclpkg/Draw
$ ls
Draw.tcl
$ tclsh8.6
% pkg_mkIndex . *.tcl
% exit
$ ls
Draw.tcl pkgIndex.tcl
$
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
package ifneeded Draw 1.0 [list source [file join $dir Draw.tcl]]
#!/bin/sh
# the next line restarts using wish \
exec wish8.6 "$0" "$@"
# 環境変数 TCLPKG が定義されていれば auto_path に追加
if {[info exist env(TCLPKG)]} {
lappend auto_path $env(TCLPKG)
}
package require Draw
# ----------------------------------------------------------------------------
# メイン
# ----------------------------------------------------------------------------
wm title . "canvas"
set color_bg "#f0fff8"
set color_grid "#c0e0d0"
set color_draw "#804040"
# キャンバスの生成
set cw 200
set ch 200
canvas .can \
-width $cw \
-height $ch \
-borderwidth 0 \
-highlightthickness 0 \
-background $color_bg
pack .can
# 方眼
for {set y 0} {$y < $ch} {incr y 10} {
.can create line 0 $y $cw $y -fill $color_grid
}
for {set x 0} {$x < $cw} {incr x 10} {
.can create line $x 0 $x $ch -fill $color_grid
}
# クラス Draw のインスタンス pen を生成
set pen [Draw new]
# メソッド init で描画色を設定
$pen init $color_draw
# マウス左ボタンを .can 上で押した時、メソッド first で座標を取得
bind .can <Button-1> {$pen first %x %y}
# マウス左ボタンを押しながら .can 上を移動した時、メソッド line を実行
bind .can <B1-Motion> {$pen line %W %x %y}
# ---
# tkwidget_canvas_3.tcl
#!/bin/sh
# the next line restarts using wish \
exec wish8.6 "$0" "$@"
package require TclOO; # ビルトインパッケージなので省略可
namespace import oo::*
# ----------------------------------------------------------------------------
# クラス Draw
# ----------------------------------------------------------------------------
class create Draw {
# ------------------------------------------------------------------------
# コンストラクタ
# ------------------------------------------------------------------------
constructor {} {
my variable conf
set conf(color) black
set conf(width) 1
}
# ------------------------------------------------------------------------
# 設定
# ------------------------------------------------------------------------
method init {color {width 1}} {
my variable conf
set conf(color) $color
set conf(width) $width
return
}
# ------------------------------------------------------------------------
# 描画起点の座標を取得
# ------------------------------------------------------------------------
method first {x y} {
my variable conf
set conf(x0) $x
set conf(y0) $y
return
}
# ------------------------------------------------------------------------
# 線を描画
# ------------------------------------------------------------------------
method line {w x y} {
my variable conf
$w create line $conf(x0) $conf(y0) $x $y \
-fill $conf(color) \
-width $conf(width) \
-tags mLine
my first $x $y
return
}
}
# ----------------------------------------------------------------------------
# メイン
# ----------------------------------------------------------------------------
wm title . "canvas"
set color_bg "#f0fff8"
set color_grid "#c0e0d0"
set color_draw "#804040"
# キャンバスの生成
set cw 200
set ch 200
canvas .can \
-width $cw \
-height $ch \
-borderwidth 0 \
-highlightthickness 0 \
-background $color_bg
pack .can
# 方眼
for {set y 0} {$y < $ch} {incr y 10} {
.can create line 0 $y $cw $y -fill $color_grid
}
for {set x 0} {$x < $cw} {incr x 10} {
.can create line $x 0 $x $ch -fill $color_grid
}
# クラス Draw のインスタンス pen を生成
set pen [Draw new]
# メソッド init で描画色を設定
$pen init $color_draw
# マウス左ボタンを .can 上で押した時、メソッド first で座標を取得
bind .can <Button-1> {$pen first %x %y}
# マウス左ボタンを押しながら .can 上を移動した時、メソッド line を実行
bind .can <B1-Motion> {$pen line %W %x %y}
# ---
# tkwidget_canvas_2.tcl
すぐりふひと（須栗歩人）の処女作、入門 Tcl/Tk の初版第一刷が出版されて、今月で十年になりました。本書は幸い何刷かの増刷を重ね、僅かばかりの印税が入りましたが、版を重ねることなく廃版となってしまっています。
しかし Tcl/Tk との付き合いは、少し疎遠になったとは言え、今も続いています。エンジニアとしてもっと手軽に GUI を扱いたいという欲求から Tcl/Tk に出会ったからでしょう。もしその時、職業プログラマとして仕事になるプログラミング言語を求めていたとしたら、Tcl/Tk は選択肢にも挙がらなかっただろうし、その結果、数多のプログラマが群がる人気プログラミング言語では執筆するチャンスにも恵まれなかったように思います。
チャンスがあれば、また書きたいものだといつも思っていますが、この手の本の寿命は驚くほど短いので、そこそこ売れて増刷や、二版、三版と改訂でも重ねないかぎり、すぐに書店から姿を消し、世間からは忘れ去られてしまいます。だいたい、Tcl/Tk なんてポピュラーなプログラミング言語ではないので、版を重ねるほどの需要はないような気もします。
せめて、インターネット上では情報を発信しつづけようと思っています。
今回は、Tcl における expr コマンドで利用できる関数を追加した拡張 wish, bwish を作ります。追加する関数は、サンプルとして立方根を計算する cbrt という C の関数を利用します。もし、お使いの Linux で最新の gcc（正確に言えば、glibc）の開発環境でない場合は念のため man cbrt でマニュアルが表示されるかどうか確認してください。利用できない場合は、適当に他の利用可能な関数に置き換えてください。MinGW クロスコンパイラの方は C99 に準拠していますので、cbrt を利用できます。/* bwish_main.c */ |
/* bwish_sub.c */ |
/* bwish.h */ |
// bwish.rc |
# Makefile |
# Makefile.win |
$ make |
$ make -fMakefile.win clean |
# Makefile.win |
$ make -fMakefile.win clean |
$ i386-mingw32-objdump -p kwish.exe | grep "DLL Name" |
$ cd /usr/local/i386-mingw32/bin |
$ unzip mingw-tcltk-8.5.1-2.zip |
/* kwish_main.c */ |
/* kwish_sub.c */ |
/* kwish.h */ |
# Makefile |
$ make |
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
# ----------------------------------------------------------------------------
# dummy work
# ----------------------------------------------------------------------------
proc dummyStart {varName} {
upvar #0 $varName x; # widget variable has gloval scope
for {set i 1} {$i <= 100} {incr i} {
set x $i
update
after 100
}
}
# ----------------------------------------------------------------------------
# MAIN
# ----------------------------------------------------------------------------
wm title . "ttk::progressbar"
ttk::style theme use "clam"
ttk::progressbar .p1 -length 200 -variable p -mode determinate
ttk::progressbar .p2 -length 200 -variable p -mode indeterminate
ttk::button .start -text "START" -command {dummyStart "p"}
grid .p1 -pady 5 -padx 10
grid .p2 -pady 5 -padx 10
grid .start -padx 10 -pady 5 -sticky news
grid columnconfigure . all -weight 1
# ---
# ttkwidget_progressbar.tcl
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
package require Iwidgets
# ----------------------------------------------------------------------------
# dummy work
# ----------------------------------------------------------------------------
proc dummyStart {w} {
$w reset
for {set i 0} {$i < 100} {incr i} {
$w step
after 100
}
}
# ----------------------------------------------------------------------------
# MAIN
# ----------------------------------------------------------------------------
wm title . "iwidgets::feedback"
iwidgets::feedback .fb \
-labeltext " percentage of completion " \
-steps 100 \
-barheight 10
button .start -text "START" \
-command {dummyStart .fb}
pack .fb -padx 4 -pady 4
pack .start -padx 4 -pady 4
# ---
# iwidgets_feedback.tcl
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
# ----------------------------------------------------------------------------
# add a tab to notebook widget
# ----------------------------------------------------------------------------
proc addTab {w n} {
set m "${w}.tab${n}"
set tlab "TAB ${n}"
ttk::frame $m
$w add $m -text $tlab
return $m
}
# ----------------------------------------------------------------------------
# MAIN
# ----------------------------------------------------------------------------
wm title . "tk::notebook"
ttk::style theme use "clam"
# make the notebook
ttk::notebook .note
pack .note -fill both -expand 1 -padx 2 -pady 2
# TAB 1
set tab1 [addTab .note 1]
$tab1 configure -width 200 -height 200
# TAB 2
set tab2 [addTab .note 2]
# TAB 3
set tab3 [addTab .note 3]
# ---
# ttkwidget_notebook.tcl
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
package require BWidget
# ----------------------------------------------------------------------------
# MAIN
# ----------------------------------------------------------------------------
wm title . "NoteBook"
# make the NoteBook
NoteBook .nb -side bottom
pack .nb
# TAB 1
set tab1 [.nb insert end 1 -text "TAB 1"]
pack [frame $tab1.f -width 200 -height 200]
# TAB 2
set tab2 [.nb insert end 2 -text "TAB 2"]
# TAB 3
set tab3 [.nb insert end 3 -text "TAB 3"]
# show TAB 1
.nb raise 1
# ---
# bwidget_notebook.tcl
#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"
# ----------------------------------------------------------------------------
# Code to populate the roots of the tree (can be more than one on Windows)
# ----------------------------------------------------------------------------
proc populateRoots {tree} {
foreach dir [lsort -dictionary [file volumes]] {
set node [$tree insert {} end -text $dir -values [list $dir directory]]
populateTree $tree $node
}
}
# ----------------------------------------------------------------------------
# Code to populate a node of the tree
# ----------------------------------------------------------------------------
proc populateTree {tree node} {
if {[$tree set $node type] ne "directory"} return
set path [$tree set $node fullpath]
$tree delete [$tree children $node]
foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] {
set type [file type $f]
set id [$tree insert $node end \
-text [file tail $f] \
-values [list $f $type]]
if {$type eq "directory"} {
# Make it so that this node is openable
$tree insert $id 0 -text dummy ;# a dummy
$tree item $id -text [file tail $f]
} elseif {$type eq "file"} {
set size [file size $f]
# Format the file size nicely
if {$size >= 1024*1024*1024} {
set size [format %.1f\ GB [expr {$size/1024/1024/1024.}]]
} elseif {$size >= 1024*1024} {
set size [format %.1f\ MB [expr {$size/1024/1024.}]]
} elseif {$size >= 1024} {
set size [format %.1f\ kB [expr {$size/1024.}]]
} else {
append size " bytes"
}
$tree set $id size $size
}
}
# Stop this code from rerunning on the current node
$tree set $node type processedDirectory
}
# ----------------------------------------------------------------------------
# MAIN
# ----------------------------------------------------------------------------
wm title . "Directory Browser"
ttk::style theme use "clam"
# Create the tree and set it up
ttk::treeview .tree \
-columns {fullpath type size} \
-displaycolumns {size} \
-yscroll ".vsb set" \
-xscroll ".hsb set"
if {[tk windowingsystem] ne "aqua"} {
ttk::scrollbar .vsb -orient vertical -command ".tree yview"
ttk::scrollbar .hsb -orient horizontal -command ".tree xview"
} else {
scrollbar .vsb -orient vertical -command ".tree yview"
scrollbar .hsb -orient horizontal -command ".tree xview"
}
.tree heading \#0 -text "Directory Structure"
.tree heading size -text "File Size"
.tree column size -stretch 0 -width 70
populateRoots .tree
bind .tree <<TreeviewOpen>> {populateTree %W [%W focus]}
# Arrange the tree and its scrollbars in the toplevel
grid .tree -column 0 -row 0 -sticky news
grid .vsb -column 1 -row 0 -sticky ns
grid .hsb -column 0 -row 1 -sticky ew
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
# ---
# ttkwidget_treeview.tcl
