davidw:
#! /bin/env wish
package require Tk
pack [label .x];pack [button .b -text Quit -command exit];set s "GUIs in Tk are Easy "
while 1 {
set s [string range $s 1 end][string index $s 0];.x configure -text $s ; update ; after 100
}I expect to see Richard Suchenwirth come up with something brilliant for this space:-)RS: Well, first a simplification of yours, using -textvar:#! /bin/env tclsh
package require Tk
pack [label .x -textv s]
pack [button .b -text Quit -comm exit]
set s "GUIs in Tk are Easy "
while 1 {
set s [string ra $s 1 end][string in $s 0]
update
after 100
}This variation cycles through the bytes from 33 to 255, in hex and character (rs):#! /bin/env tclsh
package require Tk
pack [label .x -textv s]
pack [button .b -text Quit -comm exit]
while 1 {
for {set i 33} {$i<256} {incr i} {
set s [format %X:%c $i $i];update;after 250
}
}Digital clock (rs):#! /bin/env tclsh
package require Tk
pack [label .x -textv s]
pack [button .b -text Quit -comm exit]
while 1 {
set s [clock form [clock sec] -form %H:%M:%S];update;after 1000
}AM I could not resist:#! /bin/env tclsh
package require Tk
pack [canvas .c -bg white] -fill both
.c create rectangle 50 50 70 70 -fill blue -tag R
eval [set M { .c move R [expr {5*(rand()-0.5)}] [expr {5*(rand()-0.5)} ] ; after 10 $M}]RS: The mysterious shrinking window:#! /bin/env tclsh
package require Tk
update
regexp {(.+)x.+[+](.+)[+](.+)} [wm geo .] > g x y
while {$g>0} {
wm geo . [incr g -1]x[incr g -1]+$x+$y;update;after 100
}
exitor#! /bin/env tclsh
package require Tk
update
regexp {(.+)x} [wm geo .] > g
while {$g>0} {
wm geo . [incr g -1]x[incr g -1]
update
after 100
}
exitAM: The psychedelic window:#! /bin/env tclsh
package require Tk
pack [canvas .c -bg white] -fill both
eval [set M { .c configure -bg [lindex {white black red blue green orange brown purple yellow} [expr {int(rand()*9)}]]; after 20 $M}]Shorter, by rs:#! /bin/env tclsh
package require Tk
eval [set M { . configure -bg [lindex {white black red blue green orange brown purple yellow} [expr {int(rand()*9)}]]; after 100 $M}]][wildye]: The psychadelic window, even shorter and with more random colors. I used something similar to this as a popup alert, to get my attention when someone was trying to contact me.#! /bin/env tclsh
package require Tk
eval [set M {. co -bg [format \#%06x [expr {int(rand()*0xFFFFFF)}]];after 99 $M}]PT: Blocks:#! /bin/env tclsh
package require Tk
proc S {} {
expr {int(rand()*256)}
}
proc C {} {
format #%02x%02x%02x [S] [S] [S]}
proc D {} {
.c create rectangle [S] [S] [S] [S] -fill [C]; after 100 D
}
pack [canvas .c]
DPT: Frightened window:#! /bin/env tclsh
package require Tk
proc S {} {
expr {int(rand() * 100) - 49}
}
pack [canvas .c] -expand 1 -fill both
frame .f -bg red -width 50 -height 50
bind .f <Enter> {
.c move 1 [S] [S]
}
.c create window 200 200 -window .fAM: Uncertain polka dot:#! /bin/env tclsh
package require Tk
pack [canvas .c -bg white] -fill both
proc A x {
.c move all [expr {sin(0.016*$x)}] [expr {cos(0.013*[incr x])}] ; after 10 A $x
}
.c create oval 100 100 120 120 -fill red
A 1MSW: Tcl-grep looping over argument-files:#! /bin/env tclsh
proc 1 {} {
return true
}
foreach f [lrange $argv 1 end] {
for {set fp [open $f]} {!([eof $fp] && [close $fp;1])} {
expr {[regexp [lindex $argv 0] "[set l [gets $fp]]"] && [puts $l; 1]}} {}
}TV: List all items in the Tk hierarchy (and define ilist):#! /bin/env tclsh
package require Tk
proc ilist {{begin {.}} {listf {winfo children}} {maxdepth {100}} {ident {0}}} {
if {$maxdepth <1} return
set de {}
set o {}
for {set i 0} {$i < $ident} {incr i} {
append de " "
}
foreach i [eval "$listf $begin"] {
append o "$i "; append o [ilist $i $listf [expr $maxdepth-1] [expr $ident +1]]
}
return $o
}
ilistTV: List all -text containing items in an application TV (requires ilist):#! /bin/env tclsh
package require Tk
foreach i [ilist .] {
if ![catch {$i cget -text} t1] {
if ![catch {$i cget -textvar} t2] {
if {$t1 != "$t2"} {
puts "$i [winfo class $i] [list [$i cget -text]]"
}
}
}
}TV: Enlarge all common fonts on all text containing widgets (excepting special defs) a bit:#! /bin/env tclsh
package require Tk
foreach i [ilist] {
if ![catch {set t [$i conf -font]}] {
set t [lindex $t end]
$i conf -font "[lreplace $t 1 1 [expr int(0.5+1.2*[lindex $t 1])]]"
}
}A logarithmic version could also be good. Change 1.2 to get another factor (for instance 0.8). Only works for widgets in the actual hierarchy, not for those not yet instantiated.KBK: It isn't useful, but it has quite the Perl flavor to it:#! /bin/env tclsh
puts [string map {a { P} b { a} c { c} d { T} e ck f cl g ha h od i th j {l } k no l {g } m in n Ju o st p er} nobkipapjgepchmlmdf]GPS: Incrementally display a string:#! /bin/env tclsh
package require Tk
set s "Hello World"
pack [button .b]
set i 1
while 1 {
.b config -text [string range $s 0 $i]
after [expr {int(rand() * 3000)}] [list incr i]
tkwait variable i
if {$i >= [string length $s]} break
}GPS: Print a list of packages loaded:#! /bin/env tclsh
package require Tk
proc packages.loaded? {} {
foreach p [package names] {
if {![catch {package present $p}]} { puts "$p loaded"}
}
}RS: Enumerations can be done cutely with aliases:interp alias {} colornum {} lsearch {red green blue black white}
interp alias {} numcolor {} lindex {red green blue black white}GPS: A variation on the enumerations above (RS and I were chatting):proc enum {type body} {
set l [list]
set i 0
foreach arg $body {
lappend l $arg $i; incr i
}
interp alias {} $type {} $l
}GPS: Choose a color and store what the user has selected in a label:set i 0
while 1 {
set col [tk_chooseColor]
if {{} == $col} break
pack [label .f$i -bg $col -text $col]
incr i
}GPS: A mkstemp/tmpname replacement in Tcl:proc get.unique.file.channel namePtr {
upvar $namePtr n
while 1 {
set n [file join $::env(TEMP) [clock clicks].tmp]]
if {![catch {open $n "CREAT EXCL RDWR" } fd]} {
return $fd
}
}
}willdye Generate a unique global variable name. Note that in threaded/re-entrant environments, a name clash is still possible (albeit rare). If you're worried about threads, consider "[thread::id]_[clock seconds]_[clock clicks -milliseconds]_[clock clicks]_[expr rand()]''', but I'm not an expert on threading. See also Generating a unique name.proc tmpVar {{name "tmpVar"}} {
while {[info exists ::$name]} {
append name _[clock clicks]
}
set ::$name {}
return ::$name
}willdye The answer (and question!) to Life, the Universe, and Everything:#! /bin/env tclsh set Six 1+5 set Nine 8+1 set Life $Six*$Nine puts AnswerToQuestion=[expr $Life](Note: since this wiki is intended for a wide audience, I'll risk spoiling the joke by pointing out that the above program is indeed a joke. See [1] for details.)MEd: The "floating button", press it to fill the "fish tank" with water (works even with a "full-screen tank")
#! /bin/env tclsh
package require Tk
set x 0.0
place [frame .f -bg blue] -rely 1 -relw 1 -anchor sw
place [button .b -text "Fill the Fish Tank" -command {while {$x < 0.85} {
set x [expr $x+0.005]
place .f -relh $x
place .b -rely [expr 1-$x]
update
after 30
}}] -relx 0.5 -rely 1 -anchor sMEd: Another one liner using the place command. Quite similar to to PT's frightened window, but the button can not "run away" by leaving the window.place [button .b -text "Click Me" -command {tk_messageBox -message "Got me!"}] -relx 0.5 -rely 0.5 -anchor c
bind .b <Enter> {place .b -relx [expr rand()] -rely [expr rand()]}AM: Just a play with words, but the nice thing is there are no special syntactic characters, except for a semicolon in this one:proc proc exit exit proc exit(It was too early in the morning to try when I concocted this, but perhaps it is possible to make it longer and still not use ", {, [ ...)slebetman: Here's a "real" one-liner. This doesn't cheat by using ";". A one-line slurp:
foreach data [list [read [set f [open $filename]]]] {close $f}Another way of doing it is:for {set data [read [set f [open $filename]]]} {[close $f]==2} {} {}Yet another way without cheating:if {[string length [set data [read [set f [open $filename]]]]]} {close $f} {close $f}Or in fact the most straight forward, exploiting the fact that [close] returns an empty string:set data [read [set f [open $filename]]][close $f]
Here are one line procedures for log to any base.
#Logarithm to any base:
proc log {base x} {expr {log($x)/log($base)}} ;# RS
#A faster logarithm to base two:
proc ld x "expr {log(\$x)/[expr log(2)]}" ;#RSgold: Here is a one line procedure for the factorial.
proc factorial n {
expr {$n < 2 ? 1 : $n * [factorial [incr n -1]]}
}; #[RS] recursion limitedHere is a one line procedure for testing a prime number. (See primes)
proc isprime x {
expr {$x>1 && ![regexp {^(oo+?)\1+$} [string repeat o $x]]}
}
#[SMH] returns 1 if prime and zero if not.JPT: Here's a recursive one-liner that could certainly be optimized:
proc to.binary n {expr {!$n ? 0 : "[to.binary [expr {$n>>1}]][expr {$n&1}]"} }
# alternate notation: proc binary n {expr {!$n ? 0 : "[binary [expr {$n>>1}]][expr {$n&1}]"} }
# decimal number to binary examples, binary 9 results in 1001, binary 2 results in 10
# also example of recursive procedureOther ways of converting to binary can be found on the binary representation of numbers page.JCE: So why not just this:
proc sumto n {
expr $n * ($n + 1) / 2
}sum of positive numbers to N or sum( 1 2 3 4 ... N) (see Sample Math Programs)alternate notation:`proc sumit n { expr $n * ($n + 1) / 2}`gold: Here is a one line procedure for linear interpolation. Where (xx1,yy1) and (xx3,yy3) are picked from a line. An intermediate point is picked at xx2. Solution is for yy2.
proc interlinear {xx1 xx2 xx3 yy1 yy3} {
return [expr {((($xx2-$xx1)*($yy3-$yy1))/($xx3-$xx1))+ $yy1 }]
}[gold:] I've transferred some wordy code on pi to the Oneliner's Pie in the Sky.
AMG: I would have done it this way: gold Your solution is more concise.
proc pi {} {expr acos(-1)}AMG: Here's another implementation, using expr's ?: operator instead of if:proc fib {n} {expr {$n < 2 ? $n : [fib [expr {$n - 1}]] + [fib [expr {$n - 2}]]}}willdye gave us (in the chat) links to OneLiners in awk [2] and sed [3]. Thanks.
