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
}