One Liners

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:

#! /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
}
exit

#! /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
}
exit

AM: 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]
D

PT: 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 .f

AM: 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 1

MSW: 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
}
ilist

TV: 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 [L1 ] 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 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 <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)]}"  ;#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.

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 [L2 ] and sed [L3 ]. Thanks.

Category Example

Category Tutorial