Tcl 编程/Tk 示例
< Tcl 编程
以下示例最初出现在 Tcler 的 Wiki http://wiki.tcl.tk 。它们都属于公有领域 - 无权利保留。
这个有趣的小程序生成随机的烹饪食谱。虽然它很小，但它可以生成 900 种不同的食谱，虽然它们可能不符合每个人的口味...... 基本的想法是从列表中选择一个任意元素，这在 Tcl 中很容易做到，方法如下
proc ? L {lindex $L [expr {int(rand()*[llength $L])}]}
这在以下几个地方被多次使用
proc recipe {} {
set a {
{3 eggs} {an apple} {a pound of garlic}
{a pumpkin} {20 marshmallows}
}
set b {
{Cut in small pieces} {Dissolve in lemonade}
{Bury in the ground for 3 months}
{Bake at 300 degrees} {Cook until tender}
}
set c {parsley snow nutmeg curry raisins cinnamon}
set d {
ice-cream {chocolate cake} spinach {fried potatoes} rice {soy sprouts}
}
return " Take [? $a].
[? $b].
Top with [? $c].
Serve with [? $d]."
}
并且由于现代程序总是需要一个 GUI，这里有一个最小的 GUI，它会在您在顶层源代码此文件时出现，并且每次单击它时都会显示一个新的食谱
if {[file tail [info script]]==[file tail $argv0]} {
package require Tk
pack [text .t -width 40 -height 5]
bind .t <1> {showRecipe %W; break}
proc showRecipe w {
$w delete 1.0 end
$w insert end [recipe]
}
showRecipe .t
}
尽情享用！
这是一个时钟，可以显示模拟或数字时间 - 只需单击它即可切换。
#!/usr/bin/env tclsh
package require Tk
proc every {ms body} {eval $body; after $ms [info level 0]}
proc drawhands w {
$w delete hands
set secSinceMidnight [expr {[clock sec]-[clock scan 00:00:00]}]
foreach divisor {60 3600 43200} length {45 40 30} width {1 3 7} {
set angle [expr {$secSinceMidnight * 6.283185 / $divisor}]
set x [expr {50 + $length * sin($angle)}]
set y [expr {50 - $length * cos($angle)}]
$w create line 50 50 $x $y -width $width -tags hands
}
}
proc toggle {w1 w2} {
if [winfo ismapped $w2] {
foreach {w2 w1} [list $w1 $w2] break ;# swap
}
pack forget $w1
pack $w2
}
#-- Creating the analog clock:
canvas .analog -width 100 -height 100 -bg white
every 1000 {drawhands .analog}
pack .analog
#-- Creating the digital clock:
label .digital -textvar ::time -font {Courier 24}
every 1000 {set ::time [clock format [clock sec] -format %H:%M:%S]}
bind . <1> {toggle .analog .digital}
画布的弧形元素默认情况下被渲染为饼形切片（圆周的一部分，通过半径线连接到中心。因此，生成饼图非常容易。以下代码稍微复杂一些，因为它还确定了饼图标签的位置
proc piechart {w x y width height data} {
set coords [list $x $y [expr {$x+$width}] [expr {$y+$height}]]
set xm [expr {$x+$width/2.}]
set ym [expr {$y+$height/2.}]
set rad [expr {$width/2.+20}]
set sum 0
foreach item $data {set sum [expr {$sum + [lindex $item 1]}]}
set start 270
foreach item $data {
foreach {name n color} $item break
set extent [expr {$n*360./$sum}]
$w create arc $coords -start $start -extent $extent -fill $color
set angle [expr {($start-90+$extent/2)/180.*acos(-1)}]
set tx [expr $xm-$rad*sin($angle)]
set ty [expr $ym-$rad*cos($angle)]
$w create text $tx $ty -text $name:$n -tag txt
set start [expr $start+$extent]
}
$w raise txt
}
测试
pack [canvas .c -bg white]
piechart .c 50 50 150 150 {
{SPD 199 red}
{CDU 178 gray}
{CSU 23 blue}
{FDP 60 yellow}
{Grüne 58 green}
{Linke 55 purple}
}
以下脚本在画布上显示一个条形图，带有伪 3D 条形 - 前面的矩形按指定方式绘制，并用两个多边形装饰 - 一个用于顶部，一个用于侧面：}
proc 3drect {w args} {
if [string is int -strict [lindex $args 1]] {
set coords [lrange $args 0 3]
} else {
set coords [lindex $args 0]
}
foreach {x0 y0 x1 y1} $coords break
set d [expr {($x1-$x0)/3}]
set x2 [expr {$x0+$d+1}]
set x3 [expr {$x1+$d}]
set y2 [expr {$y0-$d+1}]
set y3 [expr {$y1-$d-1}]
set id [eval [list $w create rect] $args]
set fill [$w itemcget $id -fill]
set tag [$w gettags $id]
$w create poly $x0 $y0 $x2 $y2 $x3 $y2 $x1 $y0 \
-fill [dim $fill 0.8] -outline black
$w create poly $x1 $y1 $x3 $y3 $x3 $y2 $x1 $y0 \
-fill [dim $fill 0.6] -outline black -tag $tag
}
为了更具塑性效果，多边形的填充颜色亮度降低（“变暗”）
proc dim {color factor} {
foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
set $i [expr int(255.*$n/$d*$factor)]
}
format #%02x%02x%02x $r $g $b
}
为 y 轴绘制一个简单的刻度，并返回缩放因子
proc yscale {w x0 y0 y1 min max} {
set dy [expr {$y1-$y0}]
regexp {([1-9]+)} $max -> prefix
set stepy [expr {1.*$dy/$prefix}]
set step [expr {$max/$prefix}]
set y $y0
set label $max
while {$label>=$min} {
$w create text $x0 $y -text $label -anchor w
set y [expr {$y+$stepy}]
set label [expr {$label-$step}]
}
expr {$dy/double($max)}
}
一个有趣的子挑战是粗略地对数字进行四舍五入，保留 1 或最多 2 个有效数字 - 默认情况下向上舍入，添加 "-" 向下舍入
proc roughly {n {sgn +}} {
regexp {(.+)e([+-])0*(.+)} [format %e $n] -> mant sign exp
set exp [expr $sign$exp]
if {abs($mant)<1.5} {
set mant [expr $mant*10]
incr exp -1
}
set t [expr round($mant $sgn 0.49)*pow(10,$exp)]
expr {$exp>=0? int($t): $t}
}
所以这里是我的小条形图生成器。给定画布路径名、边界矩形和要显示的数据（一个 {name value color} 三元组列表），它会计算出几何图形。首先绘制一个灰色的“地面”。注意，负值用 "d"（赤字）标记，因此它们看起来像是“穿过平面”下降的。
proc bars {w x0 y0 x1 y1 data} {
set vals 0
foreach bar $data {
lappend vals [lindex $bar 1]
}
set top [roughly [max $vals]]
set bot [roughly [min $vals] -]
set f [yscale $w $x0 $y0 $y1 $bot $top]
set x [expr $x0+30]
set dx [expr ($x1-$x0-$x)/[llength $data]]
set y3 [expr $y1-20]
set y4 [expr $y1+10]
$w create poly $x0 $y4 [expr $x0+30] $y3 $x1 $y3 [expr $x1-20] $y4 -fill gray65
set dxw [expr $dx*6/10]
foreach bar $data {
foreach {txt val col} $bar break
set y [expr {round($y1-($val*$f))}]
set y1a $y1
if {$y>$y1a} {swap y y1a}
set tag [expr {$val<0? "d": ""}]
3drect $w $x $y [expr $x+$dxw] $y1a -fill $col -tag $tag
$w create text [expr {$x+12}] [expr {$y-12}] -text $val
$w create text [expr {$x+12}] [expr {$y1a+2}] -text $txt -anchor n
incr x $dx
}
$w lower d
}
一般有用的辅助函数
proc max list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {
if {$e>$res} {set res $e}
}
set res
}
proc min list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {
if {$e<$res} {set res $e}
}
set res
}
proc swap {_a _b} {
upvar 1 $_a a $_b b
foreach {a b} [list $b $a] break
}
测试整个程序（参见截图）
pack [canvas .c -width 240 -height 280]
bars .c 10 20 240 230 {
{red 765 red}
{green 234 green}
{blue 345 blue}
{yel-\nlow 321 yellow}
{ma-\ngenta 567 magenta}
{cyan -123 cyan}
{white 400 white}
}
.c create text 120 10 -anchor nw -font {Helvetica 18} -text "Bar Chart\nDemo"
这里有一个小的 Tcl/Tk 计算器。除了屏幕上的按钮外，您还可以通过键盘输入使用 expr 的任何其他功能。
package require Tk
wm title . Calculator
grid [entry .e -textvar e -just right] -columnspan 5
bind .e <Return> =
set n 0
foreach row {
{7 8 9 + -}
{4 5 6 * /}
{1 2 3 ( )}
{C 0 . = }
} {
foreach key $row {
switch -- $key {
= {set cmd =}
C {set cmd {set clear 1; set e ""}}
default {set cmd "hit $key"}
}
lappend keys [button .[incr n] -text $key -command $cmd]
}
eval grid $keys -sticky we ;#-padx 1 -pady 1
set keys [list]
}
grid .$n -columnspan 2 ;# make last key (=) double wide
proc = {} {
regsub { =.+} $::e "" ::e ;# maybe clear previous result
if [catch {set ::res [expr [string map {/ *1.0/} $::e]]}] {
.e config -fg red
}
append ::e = $::res
.e xview end
set ::clear 1
}
proc hit {key} {
if $::clear {
set ::e ""
if ![regexp {[0-9().]} $key] {set ::e $::res}
.e config -fg black
.e icursor end
set ::clear 0
}
.e insert end $key
}
set clear 0
focus .e ;# allow keyboard input
wm resizable . 0 0
而且，正如 Cameron Laird 指出的那样，这个东西甚至可以编程：例如，输入
[proc fac x {expr {$x<2? 1: $x*[fac [incr x -1]]}}]
到输入框中，忽略警告；现在您可以执行
[fac 10]
并收到 [fac 10] = 3628800.0 作为结果...
计算尺是一种模拟的机械设备，用于近似工程计算，在 20 世纪 70 年代到 80 年代左右被袖珍计算器淘汰。基本原理是，乘法是通过加对数来完成的，因此大多数刻度是对数的，具有不均匀的增量。
这个有趣的项目用一个白色的“机身”和一个米色的“滑块”来重新创建一个计算尺（大约是 Aristo-Rietz Nr. 89，带有 7 个刻度 - 高级计算尺最多有 24 个刻度），您可以用单击的鼠标按钮 1 将其向左或向右移动，也可以用 <Shift-Left>/<Shift-Right> 方向键以像素增量移动。最后，蓝色的线代表“标记”（这个东西正确的说法是什么？“游标”？“滑块”？），您可以用鼠标在整个东西上移动它来读取一个值。用 <Left>/<Right> 键进行微调。
由于舍入误差（整数像素），这个玩具甚至比实体计算尺的精度还要低，但也许您仍然会喜欢这些回忆...... 截图显示了我是如何发现 3 乘以 7 大约是 21 的......（查看 A 和 B 刻度）。
proc ui {} {
set width 620
pack [canvas .c -width $width -height 170 -bg white]
pack [label .l -textvariable info -fg blue] -fill x
.c create rect 0 50 $width 120 -fill grey90
.c create rect 0 50 $width 120 -fill beige -outline beige \
-tag {slide slidebase}
.c create line 0 0 0 120 -tag mark -fill blue
drawScale .c K x3 10 5 5 log10 1 1000 186.6666667
drawScale .c A x2 10 50 -5 log10 1 100 280
drawScale .c B x2 10 50 5 log10 1 100 280 slide
drawScale .c CI 1/x 10 90 -5 -log10 1 10 560 slide
drawScale .c C x 10 120 -5 log10 1 10 560 slide
drawScale .c D x 10 120 5 log10 1 10 560
drawScale .c L "lg x" 10 160 -5 by100 0 10 5600
bind .c <Motion> {.c coords mark %x 0 %x 170; set info [values .c]}
bind .c <1> {set x %x}
bind .c <B1-Motion> {%W move slide [expr {%x-$x}] 0; set x %x}
bind . <Shift-Left> {.c move slide -1 0; set info [values .c]}
bind . <Shift-Right> {.c move slide 1 0; set info [values .c]}
bind . <Left> {.c move mark -1 0; set info [values .c]}
bind . <Right> {.c move mark 1 0; set info [values .c]}
}
proc drawScale {w name label x y dy f from to fac {tag {}}} {
set color [expr {[string match -* $f]? "red": "black"}]
$w create text $x [expr $y+2*$dy] -text $name -tag $tag -fill $color
$w create text 600 [expr $y+2*$dy] -text $label -tag $tag -fill $color
set x [expr {[string match -* $f]? 580: $x+10}]
set mod 5
set lastlabel ""
set lastx 0
for {set i [expr {$from*10}]} {$i<=$to*10} {incr i} {
if {$i>100} {
if {$i%10} continue ;# coarser increments
set mod 50
}
if {$i>1000} {
if {$i%100} continue ;# coarser increments
set mod 500
}
set x0 [expr $x+[$f [expr {$i/10.}]]*$fac]
set y1 [expr {$i%(2*$mod)==0? $y+2.*$dy: $i%$mod==0? $y+1.7*$dy: $y+$dy}]
set firstdigit [string index $i 0]
if {$y1==$y+$dy && abs($x0-$lastx)<2} continue
set lastx $x0
if {$i%($mod*2)==0 && $firstdigit != $lastlabel} {
$w create text $x0 [expr $y+3*$dy] -text $firstdigit \
-tag $tag -font {Helvetica 7} -fill $color
set lastlabel $firstdigit
}
$w create line $x0 $y $x0 $y1 -tag $tag -fill $color
}
}
proc values w {
set x0 [lindex [$w coords slidebase] 0]
set x1 [lindex [$w coords mark] 0]
set lgx [expr {($x1-20)/560.}]
set x [expr {pow(10,$lgx)}]
set lgxs [expr {($x1-$x0-20)/560.}]
set xs [expr {pow(10,$lgxs)}]
set res K:[format %.2f [expr {pow($x,3)}]]
append res " A:[format %.2f [expr {pow($x,2)}]]"
append res " B:[format %.2f [expr {pow($xs,2)}]]"
append res " CI:[format %.2f [expr {pow(10,-$lgxs)*10}]]"
append res " C:[format %.2f $xs]"
append res " D:[format %.2f $x]"
append res " L:[format %.2f $lgx]"
}
proc pow10 x {expr {pow(10,$x)}}
proc log10 x {expr {log10($x)}}
proc -log10 x {expr {-log10($x)}}
proc by100 x {expr {$x/100.}}
#--------------------------------
ui
bind . <Escape> {exec wish $argv0 &; exit}
这里有一个微小的但完整的脚本，允许在画布小部件上涂鸦（用鼠标绘制）
proc doodle {w {color black}} {
bind $w <1> [list doodle'start %W %x %y $color]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
proc doodle'start {w x y color} {
set ::_id [$w create line $x $y $x $y -fill $color]
}
proc doodle'move {w x y} {
$w coords $::_id [concat [$w coords $::_id] $x $y]
}
pack [canvas .c -bg white] -fill both -expand 1
doodle .c
bind .c <Double-3> {%W delete all}
这里它又来了，但这次有了解释
如果您想要这种正式的语言，它的“应用程序编程接口”（API）是 doodle 命令，您可以在其中指定哪个画布小部件应该启用涂鸦，以及用什么颜色（默认为黑色）：}
proc doodle {w {color black}} {
bind $w <1> [list doodle'start %W %x %y $color]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
它为画布注册了两个绑定，一个 (<1>) 用于单击鼠标左键，另一个用于在按住鼠标左键（1）的情况下移动鼠标。这两种绑定都只是分别调用一个内部函数。
在单击鼠标左键时，将在画布上以指定的填充颜色创建一个线条项目，但它还没有长度，因为起点和终点重合。项目 ID（由画布分配的一个数字）保存在一个全局变量中，因为它必须在该过程返回后很久才能持续存在
proc doodle'start {w x y color} {
set ::_id [$w create line $x $y $x $y -fill $color]
}
左键移动过程获取全局已知的涂鸦线条对象的坐标（交替的 x 和 y），将当前坐标附加到它，并将其设为新的坐标 - 换句话说，将线条扩展到当前鼠标位置
proc doodle'move {w x y} {
$w coords $::_id [concat [$w coords $::_id] $x $y]
}
这就是我们实现涂鸦所需的一切 - 现在让我们创建一个画布来测试它，并将其打包，这样它就可以根据您的需要绘制得很大
pack [canvas .c -bg white] -fill both -expand 1
这行代码打开了上面创建的涂鸦功能（默认为黑色）
doodle .c
为双击鼠标右键/双击按钮 3 添加一个绑定，以清除画布（由 MG 添加，2004 年 4 月 29 日）
bind .c <Double-3> {%W delete all}
这里有一个在画布上的微小的绘图程序。顶部的单选按钮允许选择绘制模式和填充颜色。在“移动”模式下，您当然可以四处移动项目。右键单击项目以将其删除。
单选按钮是一个明显的“超级小部件”，用于容纳一行单选按钮。这个简单的单选按钮允许文本或颜色模式：}
proc radio {w var values {col 0}} {
frame $w
set type [expr {$col? "-background" : "-text"}]
foreach value $values {
radiobutton $w.v$value $type $value -variable $var -value $value \
-indicatoron 0
if $col {$w.v$value config -selectcolor $value -borderwidth 3}
}
eval pack [winfo children $w] -side left
set ::$var [lindex $values 0]
set w
}
根据绘制模式，鼠标事件“按下”和“移动”具有不同的处理程序，它们由看起来像数组元素的名称调度。因此，对于模式 X，我们需要一对过程，down(X) 和 move(X)。调用之间使用的值保存在全局变量中。
首先，自由手绘线绘制的处理程序
proc down(Draw) {w x y} {
set ::ID [$w create line $x $y $x $y -fill $::Fill]
}
proc move(Draw) {w x y} {
$w coords $::ID [concat [$w coords $::ID] $x $y]
}
#-- Movement of an item
proc down(Move) {w x y} {
set ::ID [$w find withtag current]
set ::X $x; set ::Y $y
}
proc move(Move) {w x y} {
$w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
set ::X $x; set ::Y $y
}
#-- Clone an existing item
proc serializeCanvasItem {c item} {
set data [concat [$c type $item] [$c coords $item]]
foreach opt [$c itemconfigure $item] {
# Include any configuration that deviates from the default
if {[lindex $opt end] != [lindex $opt end-1]} {
lappend data [lindex $opt 0] [lindex $opt end]
}
}
return $data
}
proc down(Clone) {w x y} {
set current [$w find withtag current]
if {[string length $current] > 0} {
set itemData [serializeCanvasItem $w [$w find withtag current]]
set ::ID [eval $w create $itemData]
set ::X $x; set ::Y $y
}
}
interp alias {} move(Clone) {} move(Move)
#-- Drawing a rectangle
proc down(Rect) {w x y} {
set ::ID [$w create rect $x $y $x $y -fill $::Fill]
}
proc move(Rect) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
#-- Drawing an oval (or circle, if you're careful)
proc down(Oval) {w x y} {
set ::ID [$w create oval $x $y $x $y -fill $::Fill]
}
proc move(Oval) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
多边形是通过单击角点来绘制的。当一个角点足够靠近第一个角点时，多边形就会闭合并绘制。
proc down(Poly) {w x y} {
if [info exists ::Poly] {
set coords [$w coords $::Poly]
foreach {x0 y0} $coords break
if {hypot($y-$y0,$x-$x0)<10} {
$w delete $::Poly
$w create poly [lrange $coords 2 end] -fill $::Fill
unset ::Poly
} else {
$w coords $::Poly [concat $coords $x $y]
}
} else {
set ::Poly [$w create line $x $y $x $y -fill $::Fill]
}
}
proc move(Poly) {w x y} {#nothing}
#-- With little more coding, the Fill mode allows changing an item's fill color:
proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
proc move(Fill) {w x y} {}
#-- Building the UI
set modes {Draw Move Clone Fill Rect Oval Poly}
set colors {
black white magenta brown red orange yellow green green3 green4
cyan blue blue4 purple
}
grid [radio .1 Mode $modes] [radio .2 Fill $colors 1] -sticky nw
grid [canvas .c -relief raised -borderwidth 1] - -sticky news
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
#-- The current mode is retrieved at runtime from the global Mode variable:
bind .c <1> {down($Mode) %W %x %y}
bind .c <B1-Motion> {move($Mode) %W %x %y}
bind .c <3> {%W delete current}
要保存当前图像，您需要 Img 扩展，因此如果您没有 Img，请省略以下绑定
bind . <F1> {
package require Img
set img [image create photo -data .c]
set name [tk_getSaveFile -filetypes {{GIFF .gif} {"All files" *}}\
-defaultextension .gif]
if {$name ne ""} {$img write $name; wm title . $name}
}
#-- This is an always useful helper in development:
bind . <Escape> {exec wish $argv0 &; exit}
这里有一个非常简单的编辑器，只有 26 行代码，它只允许加载和保存文件，当然还有编辑、剪切和粘贴，以及文本小部件本身内置的任何功能。它还有一些“在线帮助”...... ;-)
用一些关于名称、目的、作者和日期的解释来开始一个源文件总是一个好主意。我最近养成了将这些信息放在一个字符串变量中的习惯（在 Tcl 中，它可以轻松地跨越多行），这样，相同的的信息就会呈现给源代码的阅读者，并且可以作为在线帮助显示：}
set about "minEd - a minimal editor Richard Suchenwirth 2003 F1: help F2: load F3: save "
图形用户界面 (GUI) 的可见部分由小部件组成。对于这个编辑器，我当然需要一个文本小部件和一个垂直滚动条。使用文本小部件的 "-wrap word" 选项，不需要额外的水平滚动条 - 超出窗口的线条会以单词边界为界进行换行。
Tk 小部件以两个步骤出现在屏幕上：首先，它们被创建并具有初始配置；然后，被传递给“几何管理器”以进行显示。由于小部件创建命令返回路径名，因此它们可以嵌套到管理器命令中（在本例中为 pack），以将所有小部件的设置保存在一个地方。但这可能会导致过长的行。
虽然滚动条位于文本的右侧，但我首先创建并打包它。原因是当用户缩小窗口时，最后打包的小部件会失去可见性。
这两行也说明了滚动条与其控制的小部件之间的耦合关系。
- 滚动条在移动时向它发送 yview 消息。
- 当视图发生变化时，例如从光标键，小部件会向滚动条发送 set 消息。
这两行已经给了我们一个用于任意长文本的编辑器，它具有内置的剪切、复制和粘贴功能——请参见文本手册页。我们只需要添加文件 I/O 才能使其真正可用。
pack [scrollbar .y -command ".t yview"] -side right -fill y pack [text .t -wrap word -yscrollc ".y set"] -side right -fill both -expand 1
你的目标是 8.4 或更高版本吗？如果是，请将 -undo 1 添加到文本选项中，以获得完整的撤消/重做支持！
pack [text .t -wrap word -yscrollc ".y set" -undo 1] -side right -fill both -expand 1
GUI 的另一个重要部分是绑定——什么事件将触发什么动作。为了简单起见，我将这里的绑定限制为标准键盘上的一些功能键。
bind . <F1> {tk_messageBox -message $about}
联机帮助使用的是一个没有花哨功能的 tk_messageBox，其“关于”文本在文件开头定义。——其他绑定调用自定义命令，这些命令从 Tk 的文件选择器对话框中获取文件名参数。
bind . <F2> {loadText .t [tk_getOpenFile]}
bind . <F3> {saveText .t [tk_getSaveFile]}
这些对话框也可以用多种方法进行配置，但即使在这种简单的形式下，它们也相当强大——允许在文件系统中导航等等。在 Windows 上，它们调用本机文件选择器，这些选择器具有以前打开文件的历史记录、详细视图（大小/日期等）。
当这个编辑器在命令行中使用文件名调用时，该文件将在启动时加载（它很简单，它一次只能处理一个文件）。
if {$argv != ""} {loadText .t [lindex $argv 0]}
加载和保存文本的过程都从对文件名参数的健全性检查开始——如果它是一个空字符串（由用户取消时文件选择器对话框生成），则它们会立即返回。否则，它们会将文件内容传输到文本小部件或反之。loadText 添加了一个“奢侈”功能，即当前文件的名称也被放入窗口标题中。然后它打开文件，清除文本小部件，一次性读取所有文件内容，并将它们放入文本小部件中。
proc loadText {w fn} {
if {$fn==""} return
wm title . [file tail $fn]
set fp [open $fn]
$w delete 1.0 end
$w insert end [read $fp]
close $fp
}
saveText 通过将范围限制为“end - 1 c”（字符）来确保不会保存文本小部件在末尾附加的额外换行符。
proc saveText {w fn} {
if {$fn==""} return
set fp [open $fn w]
puts -nonewline $fp [$w get 1.0 "end - 1 c"]
close $fp
}
文件监视
[edit | edit source]一些编辑器（例如 PFE、MS Visual Studio）在正在编辑的文件在磁盘上被更改时弹出警告对话框——这可能会导致编辑冲突。Emacs 在首次尝试更改磁盘上已更改的文件时显示一个更微妙的警告。
这里我尝试模拟此功能。它过于简化，因为它不会更新 mtime（文件修改时间）以进行检查，一旦你从编辑器本身保存了它。因此，请确保在保存后再次调用 text'watch'file。
使用全局变量 ::_twf，至少可以避免误报——对于更严肃的实现，你可能会使用按文件名索引的命名空间数组，以防你想要多个编辑窗口。}
proc text'watch'file {w file {mtime -}} {
set checkinterval 1000 ;# modify as needed
if {$mtime eq "-"} {
if [info exists ::_twf] {after cancel $::_twf}
set file [file join [pwd] $file]
text'watch'file $w $file [file mtime $file]
} else {
set newtime [file mtime $file]
if {$newtime != $mtime} {
set answer [tk_messageBox -type yesno -message \
"The file\n$file\nhas changed on disk. Reload it?"]
if {$answer eq "yes"} {text'read'file $w $file}
text'watch'file $w $file
} else {set ::_twf [after $checkinterval [info level 0]]}
}
}
proc text'read'file {w file} {
set f [open $file]
$w delete 1.0 end
$w insert end [read $f]
close $f
}
#-- Testing: pack [text .t -wrap word] -fill both -expand 1 set file textwatch.tcl text'read'file .t $file text'watch'file .t $file
当你从外部更改文件时，例如通过在纯 Tcl 中对其进行触碰，对话框应该出现，这可能是通过在另一个编辑器中对其进行编辑，或者
file mtime $filename [clock seconds]
微型演示图形
[edit | edit source]这是一个粗略的画布演示图形，它可以在 PocketPC 上运行，也可以在更大的盒子（人们可能会在那里缩放字体和尺寸）上运行。使用左/右光标或鼠标左/右键切换页面（虽然触控笔无法右键单击）。
功能不多，但代码非常紧凑，并且使用了一种可爱的用于内容规范的小语言，请参见末尾的示例（它显示了我在 2003 年纽伦堡 Euro-Tcl 大会上展示的内容……）。
proc slide args {
global slides
if {![info exist slides]} slide'init
incr slides(N)
set slides(title,$slides(N)) [join $args]
}
proc slide'line {type args} {
global slides
lappend slides(body,$slides(N)) [list $type [join $args]]
}
foreach name {* + -} {interp alias {} $name {} slide'line $name}
proc slide'init {} {
global slides
array set slides {
canvas .c N 0 show 1 dy 20
titlefont {Tahoma 22 bold} * {Tahoma 14 bold} + {Tahoma 12}
- {Courier 10}
}
pack [canvas .c -bg white] -expand 1 -fill both
foreach e {<1> <Right>} {bind . $e {slide'show 1}}
foreach e {<3> <Left>} {bind . $e {slide'show -1}}
wm geometry . +0+0
after idle {slide'show 0}
}
proc slide'show delta {
upvar #0 slides s
incr s(show) $delta
if {$s(show)<1 || $s(show)>$s(N)} {
incr s(show) [expr -$delta]
} else {
set c $s(canvas)
$c delete all
set x 10; set y 20
$c create text $x $y -anchor w -text $s(title,$s(show))\
-font $s(titlefont) -fill blue
incr y $s(dy)
$c create line $x $y 2048 $y -fill red -width 4
foreach line $s(body,$s(show)) {
foreach {type text} $line break
incr y $s(dy)
$c create text $x $y -anchor w -text $text \
-font $s($type)
}
}
}
bind . <Up> {exec wish $argv0 &; exit} ;# dev helper
剩下的就是数据——还是代码？无论如何，这是我的节目。
slide i18n - Tcl for the world + Richard Suchenwirth, Nuremberg 2003 + * i18n: internationalization + 'make software work with many languages' + * l10n: localization + 'make software work with the local language'
slide Terminology * Glyphs: + visible elements of writing * Characters: + abstract elements of writing * Byte sequences: + physical text data representation * Rendering: character -> glyph * Encoding: character <-> byte sequence
slide Before Unicode * Bacon (1580), Baudot: 5-bit encodings * Fieldata (6 bits), EBCDIC (8 bits) * ASCII (7 bits) + world-wide "kernel" of encodings * 8-bit codepages: DOS, Mac, Windows * ISO 8859-x: 16 varieties
slide East Asia * Thousands of characters/country + Solution: use 2 bytes, 94x94 matrix + Japan: JIS C-6226/0208/0212 + China: GB2312-80 + Korea: KS-C 5601 + * coexist with ASCII in EUC encodings
slide Unicode covers all * Common standard of software industry * kept in synch with ISO 10646 + Used to be 16 bits, until U 3.1 + Now needs up to 31 bits * Byte order problem: + little-endian/big-endian + U+FEFF "Byte Order Mark" + U+FFFE --illegal--
slide UTF-8 * Varying length: 1..3(..6) bytes + 1 byte: ASCII + 2 bytes: pages 00..07, Alphabets + 3 bytes: pages 08..FF, rest of BMP + >3 bytes: higher pages + * Standard in XML, coming in Unix
slide Tcl i18n
* Everything is a Unicode string (BMP)
+ internal rep: UTF-8/UCS-2
* Important commands:
- fconfigure \$ch -encoding \$e
- encoding convertfrom \$e \$s
- encoding convertto \$e \$s
+
* msgcat supports l10n:
- {"File" -> [mc "File"]}
slide Tk i18n * Any widget text is Unicoded * Automatic font finding + Fonts must be provided by system + * Missing: bidi treatment + right-to-left conversion (ar,he)
slide Input i18n
* Keyboard rebinding (bindtags)
* East Asia: keyboard buffering
+ Menu selection for ambiguities
+
* Virtual keyboard (buttons, canvas)
* String conversion: *lish family
- {[ruslish Moskva]-[greeklish Aqh'nai]}
slide i18n - Tcl for the world + + + Thank you.
时间线显示
[edit | edit source]在画布上还可以做另一件事：水平时间线的历史可视化，上面显示了年份刻度。目前有以下几种类型的对象可用。
- “eras”，以黄色显示在时间线下方，在方框中。
- “背景项”，它们是灰色的，并且在整个画布的高度上延伸。
- 普通项，它们以堆叠的橙色条形显示。
你可以使用 <1> 放大，使用 <3> 缩小（两者仅在 x 方向上）。鼠标移动时，当前年份将显示在顶层窗口的标题中。普通项可以是单个年份，例如哥伦布示例，也可以是一系列年份，例如人物的寿命。（该示例表明莫扎特没有活很长时间……）
namespace eval timeliner {
variable ""
array set "" {-zoom 1 -from 0 -to 2000}
}
proc timeliner::create {w args} {
variable ""
array set "" $args
#-- draw time scale
for {set x [expr ($(-from)/50)*50]} {$x<=$(-to)} {incr x 10} {
if {$x%50 == 0} {
$w create line $x 8 $x 0
$w create text $x 8 -text $x -anchor n
} else {
$w create line $x 5 $x 0
}
}
bind $w <Motion> {timeliner::title %W %x ; timeliner::movehair %W %x}
bind $w <1> {timeliner::zoom %W %x 1.25}
bind $w <2> {timeliner::hair %W %x}
bind $w <3> {timeliner::zoom %W %x 0.8}
}
proc timeliner::movehair {w x} {
variable ""
if {[llength [$w find withtag hair]]} {
set x [$w canvasx $x]
$w move hair [expr {$x - $(x)}] 0
set (x) $x
}
}
proc timeliner::hair {w x} {
variable ""
if {[llength [$w find withtag hair]]} {
$w delete hair
} else {
set (x) [$w canvasx $x]
$w create line $(x) 0 $(x) [$w cget -height] \
-tags hair -width 1 -fill red
}
}
proc timeliner::title {w x} {
variable ""
wm title . [expr int([$w canvasx $x]/$(-zoom))]
}
proc timeliner::zoom {w x factor} {
variable ""
$w scale all 0 0 $factor 1
set (-zoom) [expr {$(-zoom)*$factor}]
$w config -scrollregion [$w bbox all]
if {[llength [$w find withtag hair]]} {
$w delete hair
set (x) [$w canvasx $x]
$w create line $(x) 0 $(x) [$w cget -height] \
-tags hair -width 1 -fill red
}
}
此命令将对象添加到画布。对于“item”的代码，我花了一些力气，因为它必须在画布上找到一个空闲的“插槽”，从上到下搜索。
proc timeliner::add {w type name time args} {
variable ""
regexp {(\d+)(-(\d+))?} $time -> from - to
if {$to eq ""} {set to $from}
set x0 [expr {$from*$(-zoom)}]
set x1 [expr {$to*$(-zoom)}]
switch -- $type {
era {set fill yellow; set outline black; set y0 20; set y1 40}
bgitem {set fill gray; set outline {}; set y0 40; set y1 1024}
item {
set fill orange
set outline yellow
for {set y0 60} {$y0<400} {incr y0 20} {
set y1 [expr {$y0+18}]
if {[$w find overlap [expr $x0-5] $y0 $x1 $y1] eq ""} break
}
}
}
set id [$w create rect $x0 $y0 $x1 $y1 -fill $fill -outline $outline]
if {$type eq "bgitem"} {$w lower $id}
set x2 [expr {$x0+5}]
set y2 [expr {$y0+2}]
set tid [$w create text $x2 $y2 -text $name -anchor nw]
foreach arg $args {
if {$arg eq "!"} {
$w itemconfig $tid -font "[$w itemcget $tid -font] bold"
}
}
$w config -scrollregion [$w bbox all]
}
这是一个示例应用程序，它以作曲家的形式展示了音乐简明历史。
scrollbar .x -ori hori -command {.c xview}
pack .x -side bottom -fill x
canvas .c -bg white -width 600 -height 300 -xscrollcommand {.x set}
pack .c -fill both -expand 1
timeliner::create .c -from 1400 -to 2000
这些用于添加项目的简便缩写使数据规范变得轻而易举——比较原始调用和简便缩写。
timeliner::add .c item Purcell 1659-1695 - Purcell 1659-1695
使用附加的“!”参数，你可以使项目的文本变为粗体。
foreach {shorthand type} {* era x bgitem - item} {
interp alias {} $shorthand {} timeliner::add .c $type
}
现在是显示的数据（以易读的形式编写）。
* {Middle Ages} 1400-1450
- Dufay 1400-1474
* Renaissance 1450-1600
- Desprez 1440-1521
- Luther 1483-1546
- {Columbus discovers America} 1492
- Palestrina 1525-1594 !
- Lasso 1532-1594
- Byrd 1543-1623
* Baroque 1600-1750
- Dowland 1563-1626
- Monteverdi 1567-1643
- Schütz 1585-1672
- Purcell 1659-1695
- Telemann 1681-1767
- Rameau 1683-1764
- Bach,J.S. 1685-1750 !
- Händel 1685-1759
x {30-years war} 1618-1648
* {Classic era} 1750-1810
- Haydn 1732-1809 !
- Boccherini 1743-1805
- Mozart 1756-1791 !
- Beethoven 1770-1828 !
* {Romantic era} 1810-1914
- {Mendelssohn Bartholdy} 1809-1847
- Chopin 1810-1849
- Liszt 1811-1886
- Verdi 1813-1901
x {French revolution} 1789-1800
* {Modern era} 1914-2000
- Ravel 1875-1937 !
- Bartók 1881-1945
- Stravinskij 1882-1971
- Varèse 1883-1965
- Prokof'ev 1891-1953
- Milhaud 1892-1974
- Honegger 1892-1955
- Hindemith 1895-1963
- Britten 1913-1976
x WW1 1914-1918
x WW2 1938-1945
函数乐
[edit | edit source]
我十几岁的女儿讨厌数学。为了激励她，我加强了之前的一个小函数绘图器，该绘图器以前只能从命令行获取一个函数，并使用严格的 Tcl（expr）表示法。现在有一个条目小部件，并且接受的语言也得到了丰富：除了 exprs 规则之外，你还可以省略美元符号和乘号，例如 2x+1，幂可以写成 x3 而不是 ($x*$x*$x)；在简单的情况下，你可以省略围绕函数参数的括号，例如 sin x2。在条目小部件中按
如果你需要一些想法，请单击“?”按钮以循环浏览一组演示函数，从无聊到古怪（例如，如果使用 rand()）。除了默认缩放之外，你还可以放大或缩小。将鼠标指针移到画布上会显示 x 和 y 坐标，如果你在曲线上的某个点上，则显示会变为白色。
目标没有达到：我女儿仍然讨厌数学。但至少我又有了几个小时的 Tcl（和函数）乐趣，在笛卡尔平面上冲浪……希望你也喜欢它！
proc main {} {
canvas .c -bg white -borderwidth 0
bind .c <Motion> {displayXY .info %x %y}
frame .f
label .f.1 -text "f(x) = "
entry .f.f -textvar ::function -width 40
bind .f.f <Return> {plotf .c $::function}
button .f.demo -text " ? " -pady 0 -command {demo .c}
label .f.2 -text " Zoom: "
entry .f.fac -textvar ::factor -width 4
set ::factor 32
bind .f.fac <Return> {zoom .c 1.0}
button .f.plus -text " + " -pady 0 -command {zoom .c 2.0}
button .f.minus -text " - " -pady 0 -command {zoom .c 0.5}
eval pack [winfo children .f] -side left -fill both
label .info -textvar ::info -just left
pack .info .f -fill x -side bottom
pack .c -fill both -expand 1
demo .c
}
set ::demos {
"cos x3" 2 1-x 0.5x2 x3/5 "sin x" "sin x2" 1/x sqrt(x)
"tan x/5" x+1/x x abs(x) "exp x" "log x" "log x2"
round(x) "int x%2" "x-int x" "0.2tan x+1/tan x" x*(rand()-0.5)
x2/5-1/(2x) "atan x" sqrt(1-x2) "abs(x-int(x*2))" (x-1)/(x+1)
"sin x-tan x" "sin x-tan x2" "x-abs(int x)" 0.5x-1/x
-0.5x3+x2+x-1 3*sin(2x) -0.05x4-0.2x3+1.5x2+2x-3 "9%int x"
0.5x2/(x3-3x2+4) "abs x2-3 int x" "int x%3"
}
proc displayXY {w cx cy} {
set x [expr {double($cx-$::dx)/$::factor}]
set y [expr {double(-$cy+$::dy)/$::factor}]
set ::info [format "x=%.2f y=%.2f" $x $y]
catch {
$w config -fg [expr {abs([expr $::fun]-$y)<0.01?"white":"black"}]
} ;# may divide by zero, or other illegal things
}
proc zoom {w howmuch} {
set ::factor [expr round($::factor*$howmuch)]
plotf $w $::function
}
proc plotf {w function} {
foreach {re subst} {
{([a-z]) +(x[0-9]?)} {\1(\2)} " " "" {([0-9])([a-z])} {\1*\2}
x2 x*x x3 x*x*x x4 x*x*x*x x \$x {e\$xp} exp
} {regsub -all $re $function $subst function}
set ::fun $function
set ::info "Tcl: expr $::fun"
set color [lpick {red blue purple brown green}]
plotline $w [fun2points $::fun] -fill $color
}
proc lpick L {lindex $L [expr {int(rand()*[llength $L])}]}
proc fun2points {fun args} {
array set opt {-from -10.0 -to 10.0 -step .01}
array set opt $args
set res "{"
for {set x $opt(-from)} {$x<= $opt(-to)} {set x [expr {$x+$opt(-step)}]} {
if {![catch {expr $fun} y]} {
if {[info exists lasty] && abs($y-$lasty)>100} {
append res "\} \{" ;# incontinuity
}
append res " $x $y"
set lasty $y
} else {append res "\} \{"}
}
append res "}"
}
proc plotline {w points args} {
$w delete all
foreach i $points {
if {[llength $i]>2} {eval $w create line $i $args -tags f}
}
set fac $::factor
$w scale all 0 0 $fac -$fac
$w create line -10000 0 10000 0 ;# X axis
$w create line 0 -10000 0 10000 ;# Y axis
$w create line $fac 0 $fac -3 ;# x=1 tick
$w create line -3 -$fac 0 -$fac ;# y=1 tick
set ::dx [expr {[$w cget -width]/2}]
set ::dy [expr {[$w cget -height]/2}]
$w move all $::dx $::dy
$w raise f
}
proc demo {w} {
set ::function [lindex $::demos 0] ;# cycle through...
set ::demos [concat [lrange $::demos 1 end] [list $::function]]
set ::factor 32
plotf $w $::function
}
main
功能成像
[edit | edit source]在 Conal Elliott 的 Pan 项目（“功能图像合成”，[1]）中，图像（任意大小和分辨率）以一种优雅的功能方式生成和操作。用 Haskell 编写的函数（参见 Playing Haskell）被应用，主要以函数组合的形式应用于像素，以返回它们的色值。常见问题解答：“我们也可以在 Tcl 中这样做吗？”
正如下面的 funimj 演示所示，原则上可以；但这需要一些耐心（或非常快的 CPU）——对于一个 200x200 的图像，该函数被调用了 40000 次，在我的 P200 盒子上需要 9..48 秒。尽管如此，输出通常值得等待……并且编写此代码所花费的时间微不足道，因为 Haskell 原件只需稍加修改即可在 Tcl 中表示。函数组合必须重写为 Tcl 的波兰表示法——Haskell 的
foo 1 o bar 2 o grill
（其中“o”是组合运算符）在 Tcl 中将如下所示
o {foo 1} {bar 2} grill
正如示例所示，可以指定其他参数；只有最后一个参数通过生成的“函数嵌套”传递。
proc f {x} {foo 1 [bar 2 [grill $x]]}
但生成的函数的名称比“f”好得多：即，对“o”的完整调用被使用，因此示例 proc 的名称是
"o {foo 1} {bar 2} grill"
这很有自说明性 ;-）我这样实现了“o”。
proc o args {
# combine the functions in args, return the created name
set name [info level 0]
set body "[join $args " \["] \$x"
append body [string repeat \] [expr {[llength $args]-1}]]
proc $name x $body
set name
}
# Now for the rendering framework:
proc fim {f {zoom 100} {width 200} {height -}} {
# produce a photo image by applying function f to pixels
if {$height=="-"} {set height $width}
set im [image create photo -height $height -width $width]
set data {}
set xs {}
for {set j 0} {$j<$width} {incr j} {
lappend xs [expr {($j-$width/2.)/$zoom}]
}
for {set i 0} {$i<$height} {incr i} {
set row {}
set y [expr {($i-$height/2.)/$zoom}]
foreach x $xs {
lappend row [$f [list $x $y]]
}
lappend data $row
}
$im put $data
set im
}
基本成像函数（“绘图器”）具有共同的功能点 -> 颜色，其中点是一对 {x y}（或者，在应用极坐标变换后，{r a}……），颜色是 Tk 颜色名称，例如“green”或 #010203。
proc vstrip p {
# a simple vertical bar
b2c [expr {abs([lindex $p 0]) < 0.5}]
}
proc udisk p {
# unit circle with radius 1
foreach {x y} $p break
b2c [expr {hypot($x,$y) < 1}]
}
proc xor {f1 f2 p} {
lappend f1 $p; lappend f2 $p
b2c [expr {[eval $f1] != [eval $f2]}]
}
proc and {f1 f2 p} {
lappend f1 $p; lappend f2 $p
b2c [expr {[eval $f1] == "#000" && [eval $f2] == "#000"}]
}
proc checker p {
# black and white checkerboard
foreach {x y} $p break
b2c [expr {int(floor($x)+floor($y)) % 2 == 0}]
}
proc gChecker p {
# greylevels correspond to fractional part of x,y
foreach {x y} $p break
g2c [expr {(fmod(abs($x),1.)*fmod(abs($y),1.))}]
}
proc bRings p {
# binary concentric rings
foreach {x y} $p break
b2c [expr {round(hypot($x,$y)) % 2 == 0}]
}
proc gRings p {
# grayscale concentric rings
foreach {x y} $p break
g2c [expr {(1 + cos(3.14159265359 * hypot($x,$y))) / 2.}]
}
proc radReg {n p} {
# n wedge slices starting at (0,0)
foreach {r a} [toPolars $p] break
b2c [expr {int(floor($a*$n/3.14159265359))%2 == 0}]
}
proc xPos p {b2c [expr {[lindex $p 0]>0}]}
proc cGrad p {
# color gradients - best watched at zoom=100
foreach {x y} $p break
if {abs($x)>1.} {set x 1.}
if {abs($y)>1.} {set y 1.}
set r [expr {int((1.-abs($x))*255.)}]
set g [expr {int((sqrt(2.)-hypot($x,$y))*180.)}]
set b [expr {int((1.-abs($y))*255.)}]
c2c $r $g $b
}
除了 Conal Elliott 论文中的示例外，我发现功能成像也可以被滥用于（缓慢且不精确的）函数绘图器，如果你使用 $y + f($x) 作为第一个参数调用它，则该绘图器会显示 y = f(x) 的图形。
proc fplot {expr p} {
foreach {x y} $p break
b2c [expr abs($expr)<=0.04] ;# double eval required here!
}
这里有一个用于两个二进制图像的组合器，它以不同的颜色显示两个图像中的哪一个点是“真”的——很好但很慢：}
proc bin2 {f1 f2 p} {
set a [eval $f1 [list $p]]
set b [eval $f2 [list $p]]
expr {
$a == "#000" ?
$b == "#000" ? "green"
: "yellow"
: $b == "#000" ? "blue"
: "black"
}
}
#--------------------------------------- Pixel converters:
proc g2c {greylevel} {
# convert 0..1 to #000000..#FFFFFF
set hex [format %02X [expr {round($greylevel*255)}]]
return #$hex$hex$hex
}
proc b2c {binpixel} {
# 0 -> white, 1 -> black
expr {$binpixel? "#000" : "#FFF"}
}
proc c2c {r g b} {
# make Tk color name: {0 128 255} -> #0080FF
format #%02X%02X%02X $r $g $b
}
proc bPaint {color0 color1 pixel} {
# convert a binary pixel to one of two specified colors
expr {$pixel=="#000"? $color0 : $color1}
}
此绘图器以给定颜色的色调对灰度图像进行着色。它通过除以“白色”的相应值来规范给定颜色，但看起来也很慢。
proc gPaint {color pixel} {
set abspixel [lindex [rgb $pixel] 0]
set rgb [rgb $color]
set rgbw [rgb white]
foreach var {r g b} in $rgb ref $rgbw {
set $var [expr {round(double($abspixel)*$in/$ref/$ref*255.)}]
}
c2c $r $g $b
}
此 proc 缓存 [winfo rgb] 调用的结果，因为这些调用相当昂贵，尤其是在远程 X 显示器上 - rmax。
proc rgb {color} {
upvar "#0" rgb($color) rgb
if {![info exists rgb]} {set rgb [winfo rgb . $color]}
set rgb
}
#------------------------------ point -> point transformers
proc fromPolars p {
foreach {r a} $p break
list [expr {$r*cos($a)}] [expr {$r*sin($a)}]
}
proc toPolars p {
foreach {x y} $p break
# for Sun, we have to make sure atan2 gets no two 0's
list [expr {hypot($x,$y)}] [expr {$x||$y? atan2($y,$x): 0}]
}
proc radInvert p {
foreach {r a} [toPolars $p] break
fromPolars [list [expr {$r? 1/$r: 9999999}] $a]
}
proc rippleRad {n s p} {
foreach {r a} [toPolars $p] break
fromPolars [list [expr {$r*(1.+$s*sin($n*$a))}] $a]
}
proc slice {n p} {
foreach {r a} $p break
list $r [expr {$a*$n/3.14159265359}]
}
proc rotate {angle p} {
foreach {x y} $p break
set x1 [expr {$x*cos(-$angle) - $y*sin(-$angle)}]
set y1 [expr {$y*cos(-$angle) + $x*sin(-$angle)}]
list $x1 $y1
}
proc swirl {radius p} {
foreach {x y} $p break
set angle [expr {hypot($x,$y)*6.283185306/$radius}]
rotate $angle $p
}
现在是演示程序。它在按钮栏上显示预定义的基本图像运算符和一些组合。单击一个按钮，耐心等待，相应的图像将显示在右侧的画布上。你也可以在底部的条目小部件中尝试使用图像运算符——按
- 组合运算符“o”
- 零个或多个“绘图器”（颜色 -> 颜色）
- 一个“绘图器”（点 -> 颜色）
- 零个或多个“变换器”（点 -> 点）
}
proc fim'show {c f} {
$c delete all
set ::try $f ;# prepare for editing
set t0 [clock seconds]
. config -cursor watch
update ;# to make the cursor visible
$c create image 0 0 -anchor nw -image [fim $f $::zoom]
wm title . "$f: [expr [clock seconds]-$t0] seconds"
. config -cursor {}
}
proc fim'try {c varName} {
upvar #0 $varName var
$c delete all
if [catch {fim'show $c [eval $var]}] {
$c create text 10 10 -anchor nw -text $::errorInfo
}
}
组合函数只需要提到一次，这将创建它们，并且它们以后可以通过信息过程获取。这里的 o 看起来很像子弹……
o bRings
o cGrad
o checker
o gRings
o vstrip
o xPos
o {bPaint brown beige} checker
o checker {slice 10} toPolars
o checker {rotate 0.1}
o vstrip {swirl 1.5}
o checker {swirl 16}
o {fplot {$y + exp($x)}}
o checker radInvert
o gRings {rippleRad 8 0.3}
o xPos {swirl .75}
o gChecker
o {gPaint red} gRings
o {bin2 {radReg 7} udisk}
#----------------------------------------------- testing
frame .f2
set c [canvas .f2.c]
set e [entry .f2.e -bg white -textvar try]
bind $e <Return> [list fim'try $c ::try]
scale .f2.s -from 1 -to 100 -variable zoom -ori hori -width 6
#--------------------------------- button bar:
frame .f
set n 0
foreach imf [lsort [info procs "o *"]] {
button .f.b[incr n] -text $imf -anchor w -pady 0 \
-command [list fim'show $c $imf]
}
set ::zoom 25
eval pack [winfo children .f] -side top -fill x -ipady 0
eval pack [winfo children .f2] -side top -fill x
pack .f .f2 -side left -anchor n
bind . <Escape> {exec wish $argv0 &; exit} ;# dev helper
bind . ? {console show} ;# dev helper, Win/Mac only
TkPhotoLab
[edit | edit source]以下代码可用于图像处理实验，包括
- 卷积（见下文）
- 从颜色到灰度级别的转换
- 灰度级到伪彩色转换
- 亮度和对比度修改
Tcl 在处理大量数字运算方面并不快，例如处理数千个像素时，但我不建议在有趣的项目中使用 C ;) 所以慢慢来，或者找一个真正的 CPU。至少您可以观察进度，因为目标图像会在每行处理后更新。
拉普拉斯 5 滤波器边缘增强
演示 UI 显示两个图像，左侧是原始图像，右侧是处理结果。您可以使用“选项/接受”将结果推到左侧。查看菜单以了解我提供的功能。但最让我感兴趣的是“卷积”，您可以编辑矩阵（固定为 3x3 - 速度足够慢..）并单击“应用”以在输入图像上运行它。“C” 将矩阵设置为全零。
卷积是一种技术，其中目标像素的颜色根据给定矩阵及其邻居的乘积之和来确定。例如，卷积矩阵
1 1 1 1 1 1 1 1 1
使用自身及其八个邻居的平均值对中间的像素进行着色，这将模糊图像。
0 0 0 0 1 0 0 0 0
应该忠实地复制输入图像。这些
0 -1 0 -1 -1 -1 -1 5 -1 or: -1 9 -1 0 -1 0 -1 -1 -1
增强{水平，垂直}边缘，使图像看起来更“清晰”。}
proc convolute {inimg outimg matrix} {
set w [image width $inimg]
set h [image height $inimg]
set matrix [normalize $matrix]
set shift [expr {[matsum $matrix]==0? 128: 0}]
set imat [photo2matrix $inimg]
for {set i 1} {$i<$h-1} {incr i} {
set row {}
for {set j 1} {$j<$w-1} {incr j} {
foreach var {rsum gsum bsum} {set $var 0.0}
set y [expr {$i-1}]
foreach k {0 1 2} {
set x [expr {$j-1}]
foreach l {0 1 2} {
if {[set fac [lindex $matrix $k $l]]} {
foreach {r g b} [lindex $imat $y $x] {}
set rsum [expr {$rsum + $r * $fac}]
set gsum [expr {$gsum + $g * $fac}]
set bsum [expr {$bsum + $b * $fac}]
}
incr x
}
incr y
}
if {$shift} {
set rsum [expr {$rsum + $shift}]
set gsum [expr {$gsum + $shift}]
set bsum [expr {$bsum + $shift}]
}
lappend row [rgb [clip $rsum] [clip $gsum] [clip $bsum]]
}
$outimg put [list $row] -to 1 $i
update idletasks
}
}
proc alias {name args} {eval [linsert $args 0 interp alias {} $name {}]}
alias rgb format #%02x%02x%02x
proc lambda {argl body} {K [set n [info level 0]] [proc $n $argl $body]}
proc K {a b} {set a}
proc clip x {expr {$x>255? 255: $x<0? 0: int($x)}}
proc photo2matrix image {
set w [image width $image]
set h [image height $image]
set res {}
for {set y 0} {$y<$h} {incr y} {
set row {}
for {set x 0} {$x<$w} {incr x} {
lappend row [$image get $x $y]
}
lappend res $row
}
set res
}
proc normalize matrix {
#-- make sure all matrix elements add up to 1.0
set sum [matsum $matrix]
if {$sum==0} {return $matrix} ;# no-op on zero sum
set res {}
foreach inrow $matrix {
set row {}
foreach el $inrow {lappend row [expr {1.0*$el/$sum}]}
lappend res $row
}
set res
}
proc matsum matrix {expr [join [join $matrix] +]}
以下例程也可以通用化为一个
proc color2gray image {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$image get $j $i] break
set y [expr {int(0.299*$r + 0.587*$g + 0.114*$b)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 $i
update idletasks
}
}
proc color2gray2 image {
set i -1
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
foreach {r g b} $pixel break
set y [expr {int(($r + $g + $b)/3.)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}
将灰度级分类为非真实颜色的实验
proc gray2color image {
set i -1
set colors {black darkblue blue purple red orange yellow white}
set n [llength $colors]
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
set index [expr {[lindex $pixel 0]*$n/256}]
lappend row [lindex $colors $index]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}
proc grayWedge image {
$image blank
for {set i 0} {$i<256} {incr i} {
$image put [rgb $i $i $i] -to $i 0 [expr {$i+1}] 127
}
}
许多算法非常相似，仅在中心的一些命令上有区别。因此我将它们通用化，它们接受一个函数名称，该函数名称应用于每个像素 rgb，或者一对像素 rgb。它们由一个别名实例化，该别名将函数巧妙地设置为 lambda
proc generic_1 {f target source} {
set w [image width $source]
set h [image height $source]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$source get $j $i] break
lappend row [rgb [$f $r] [$f $g] [$f $b]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias invert generic_1 [lambda x {expr {255-$x}}]
alias contrast+ generic_1 [lambda x {clip [expr {128+($x-128)*1.25}]}]
alias contrast- generic_1 [lambda x {clip [expr {128+($x-128)*0.8}]}]
proc generic_2 {f target with} {
set w [image width $target]
set h [image height $target]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$target get $j $i] break
foreach {r1 g1 b1} [$with get $j $i] break
lappend row [rgb [$f $r $r1] [$f $g $g1] [$f $b $b1]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias blend generic_2 [lambda {a b} {expr {($a+$b)/2}}]
alias difference generic_2 [lambda {a b} {expr {255-abs($a-$b)}}]
直方图是当前图像中每个颜色值出现的次数，分别针对红色、绿色和蓝色。对于灰度图像，显示的“曲线”应该完全重叠，因此您只能看到最后绘制的蓝色点。
proc histogram {image {channel 0}} {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<256} {incr i} {set hist($i) 0}
for {set i 0} {$i<$h} {incr i} {
for {set j 0} {$j<$w} {incr j} {
incr hist([lindex [$image get $j $i] $channel])
}
}
set res {}
for {set i 0} {$i<256} {incr i} {lappend res $hist($i)}
set res
}
proc drawHistogram {target input} {
$target blank
set a [expr {6000./([image height $input]*[image width $input])}]
foreach color {red green blue} channel {0 1 2} {
set i -1
foreach val [histogram $input $channel] {
$target put $color -to [incr i] \
[clip [expr {int(128-$val*$a)}]]
}
update idletasks
}
}
演示 UI
if {[file tail [info script]] eq [file tail $argv0]} {
package require Img ;# for JPEG etc.
proc setFilter {w matrix} {
$w delete 1.0 end
foreach row $matrix {$w insert end [join $row \t]\n}
set ::info "Click 'Apply' to use this filter"
}
label .title -text TkPhotoLab -font {Helvetica 14 italic} -fg blue
label .( -text ( -font {Courier 32}
set txt [text .t -width 20 -height 3]
setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}
label .) -text ) -font {Courier 32}
button .c -text C -command {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
grid .title .( .t .) .c -sticky news
button .apply -text Apply -command applyConv
grid x ^ ^ ^ .apply -sticky ew
grid [label .0 -textvar info] - - -sticky w
grid [label .1] - [label .2] - - -sticky new
proc loadImg { {fn ""}} {
if {$fn==""} {set fn [tk_getOpenFile]}
if {$fn != ""} {
cd [file dirname [file join [pwd] $fn]]
set ::im1 [image create photo -file $fn]
.1 config -image $::im1
set ::im2 [image create photo]
.2 config -image $::im2
$::im2 copy $::im1 -shrink
set ::info "Loaded image 1 from $fn"
}
}
proc saveImg { {fn ""}} {
if {$fn==""} {set fn [tk_getSaveFile]}
if {$fn != ""} {
$::im2 write $fn -format JPEG
set ::info "Saved image 2 to $fn"
}
}
proc applyConv {} {
set ::info "Convolution running, have patience..."
set t0 [clock clicks -milliseconds]
convolute $::im1 $::im2 [split [$::txt get 1.0 end] \n]
set dt [expr {([clock click -milliseconds]-$t0)/1000.}]
set ::info "Ready after $dt sec"
}
一个用于简化菜单创建的小包装器 - 请参见下面的用法
proc m+ {head name {cmd ""}} {
if {![winfo exists .m.m$head]} {
.m add cascade -label $head -menu [menu .m.m$head -tearoff 0]
}
if [regexp ^-+$ $name] {
.m.m$head add separator
} else {.m.m$head add command -label $name -comm $cmd}
}
. config -menu [menu .m] m+ File Open.. loadImg m+ File Save.. saveImg m+ File --- m+ File Exit exit
m+ Edit Blend {blend $im2 $im1}
m+ Edit Difference {difference $im2 $im1}
m+ Edit ---
m+ Edit Negative {invert $im2 $im1}
m+ Edit Contrast+ {contrast+ $im2 $im1}
m+ Edit Contrast- {contrast- $im2 $im1}
m+ Edit ---
m+ Edit Graylevel {$im2 copy $im1 -shrink; color2gray $im2}
m+ Edit Graylevel2 {$im2 copy $im1 -shrink; color2gray2 $im2}
m+ Edit "Add Noise" {
generic_1 [lambda x {expr {rand()<.01? int(rand()*255):$x}}] $im2 $im1
}
m+ Edit gray2color {$im2 copy $im1 -shrink; gray2color $im2}
m+ Edit Octary {generic_1 [lambda x {expr {$x>127? 255:0}}] $im2 $im1}
m+ Edit ---
m+ Edit HoriMirror {$im2 copy $im1 -shrink -subsample -1 1}
m+ Edit VertMirror {$im2 copy $im1 -shrink -subsample 1 -1}
m+ Edit "Upside down" {$im2 copy $im1 -shrink -subsample -1 -1}
m+ Edit ---
m+ Edit "Zoom x 2" {$im2 copy $im1 -shrink -zoom 2}
m+ Edit "Zoom x 3" {$im2 copy $im1 -shrink -zoom 3}
m+ Options "Accept (1<-2)" {$im1 copy $im2 -shrink}
m+ Options ---
m+ Options "Gray wedge" {grayWedge $im2}
m+ Options Histogram {drawHistogram $im2 $im1}
m+ Filter Clear {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
m+ Filter ---
m+ Filter Blur0 {setFilter .t {{1 1 1} {1 0 1} {1 1 1}}}
m+ Filter Blur1 {setFilter .t {{1 1 1} {1 1 1} {1 1 1}}}
m+ Filter Gauss2 {setFilter .t {{1 2 1} {2 4 2} {1 2 1}}}
m+ Filter ---
m+ Filter Laplace5 {setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}}
m+ Filter Laplace9 {setFilter .t {{-1 -1 -1} {-1 9 -1} {-1 -1 -1}}}
m+ Filter LaplaceX {setFilter .t {{1 -2 1} {-2 5 -2} {1 -2 1}}}
m+ Filter ---
m+ Filter Emboss {setFilter .t {{2 0 0} {0 -1 0} {0 0 -1}}}
m+ Filter HoriEdge {setFilter .t {{-1 -1 -1} {0 0 0} {1 1 1}}}
m+ Filter VertEdge {setFilter .t {{-1 0 1} {-1 0 1} {-1 0 1}}}
m+ Filter SobelH {setFilter .t {{1 2 1} {0 0 0} {-1 -2 -1}}}
m+ Filter SobelV {setFilter .t {{1 0 -1} {2 0 -2} {1 0 -1}}}
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}
loadImg aaa.jpg
}