One (possibly) long line Tcl or Tk scripts that are cute/neat/fun. Tcl is more verbose than perl, so I guess we won't see some of the brain-twisters those guys come up with, but I think some neat things can be done. ''[FW]: These are just shortish scripts smushed into one line. A strict one-liner actually occupies one, maybe two or three lines using standard formatting, and is much harder to make anything useful out of. I dare you to try.'' [TV] For what it is worth, I would type mine in practice actually as one line... [Mike Tuxford]: Looking at some of these with procs, loops, semi-colons, etc... I have to agree with [FW]. After all, isn't every script a one-liner to the parser? [LES]: I really dislike this page. All semi-colons in these (mostly) impostor one-liners totally ruin the poetry or challenge of the proposition. The right way to contribute to this page would have been with some of the ideas that have been contributed to [Bag of algorithms]. Check that page and see how it actually has more true and useful one-liners than this page, which goes to show even further how pointless this page turns out to be. The main difference between the two pages seems to be that in [Bag of algorithms] people seem to look for things that are actually useful regardless of size and some them just happen to be true one-liners, whereas in this page people strive to show something clever or impressive that has-to-fit-in-one-line-one-way-or-the-other-damn-it. Besides, Tcl is not Perl. ---- [davidw]: ====== echo '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}' | wish ====== I expect to see [Richard Suchenwirth] come up with something brilliant for this space:-) [RS]: Well, first a simplification of yours, using -textvar: ====== echo '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}' | wish ====== This variation cycles through the bytes from 33 to 255, in hex and character (rs): ====== echo '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}}' | wish ====== Digital clock (rs): ====== echo '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}' | wish ====== [AM] I could not resist: ====== echo '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} ]' | wish ====== The mysterious shrinking window ([RS]): ====== echo '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};exit' | wish ====== or ====== echo 'update;regexp {(.+)x} [wm geo .] > g;while {$g>0} {wm geo . [incr g -1]x[incr g -1];update;after 100};exit' | wish ====== The psychedelic window ([AM]): ====== echo '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}]]' | wish ====== Shorter, by rs: ====== echo 'eval [set M { . configure -bg [lindex {white black red blue green orange brown purple yellow} [expr {int(rand()*9)}]]; after 100 $M}]]' | wish ====== 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. [willdye] ====== echo 'eval [set M {. co -bg [format \#%06x [expr {int(rand()*0xFFFFFF)}]];after 99 $M}]'|wish ====== Blocks ([PT]): ====== echo '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]; D' | wish ====== Frightened window ([PT]): ====== echo 'proc S {} {expr {int(rand() * 100) - 49}};pack [canvas .c] -expand 1 -fill both;frame .f -bg red -width 50 -height 50;bind .f {.c move 1 [S] [S]};.c create window 200 200 -window .f' | wish ====== Uncertain polka dot ([AM]): ====== echo '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 1' | wish ====== Tcl-grep looping over argument-files ([MSW]): ====== 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]}} {}} ====== List all items in the Tk hierarchy (and define ilist) [TV]: ====== 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 } ; ilist ====== List all -text containing items in an application [TV] (requires [ilist]): ====== 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]]"} }} ; } ====== Enlarge all common fonts on all text containing widgets (excepting special defs) a bit [TV]: ====== 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])]]" }} ====== An 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: ====== 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: ====== 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: ====== 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: ====== echo 'set Six 1+5; set Nine 8+1; set Life $Six*$Nine; puts AnswerToQuestion=[expr $Life]'|tclsh ====== (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 [http://en.wikipedia.org/wiki/The_Answer_to_Life%2C_the_Universe%2C_and_Everything#Attempts_to_make_.226_x_9_.3D_42.22_mathematically_correct] for details.) [MEd] The "floating button", press it to fill the "fish tank" with water (works even with a "full-screen tank") ====== 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 s ====== [MEd] 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 {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)]}" ;#RS ====== ---- [gold] Here is a one line procedure for the [factorial]. ====== proc factorial n { expr {$n < 2 ? 1 : $n * [factorial [incr n -1]]} }; #[RS] recursion limited ====== ---- Here 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 procedure ====== Other 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] ,http://wiki.tcl.tk/26549. ---- [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] [http://www.student.northpark.edu/pemente/awk/awk1line.txt] and [sed] [http://www.student.northpark.edu/pemente/sed/sed1line.txt]. Thanks. <> Example | Tutorial