Version 509 of One Liners

Updated 2011-05-16 00:18:19 by gold

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