[Richard Suchenwirth] 1999-07-21 - I much too late discovered the "99 bottles of beer" game, where the text of the admittedly silly song
        99 bottles of beer on the wall, 99 bottles of beer.
        Take one down, pass it around,
        98 bottles of beer.
        ... (downto 0)
has to be produced by a program. Tim Robinson (timtroyr@ionet.net)
exhibits a collection of presently 227 programming languages (some with >1
example) in http://www.westnet.com/mirrors/99bottles/beer.html

'''(This person's pages at www.ionet.net appear to have completely disappeared. Anyone know anything?)'''[RS]: Yes - just found http://internet.ls-la.net/mirrors/99bottles/

[HJG] They moved to http://www.99-bottles-of-beer.net and http://www.99-bottles-of-beer.net/language-tcl-439.html

Tcl is represented there with a program by [Don Libes] http://www.ionet.net/~timtroyr/funhouse/beer/beer_s_z.html#tcl, also see [Expect] and [Itcl], but there's more than one way to do it, as they say. In a joyful discussion in news:comp.lang.tcl, the following code was jointly developed:

  proc en:num {n {optional 0}} {
    #---------------- English spelling for integer numbers
    if {[catch {set n [expr $n]}]}  {return $n}
    if {$optional && $n==0} {return ""}
    array set dic {
        0 zero 1 one 2 two 3 three 4 four 5 five 6 six 7 seven 
        8 eight 9 nine 10 ten 11 eleven 12 twelve
    }
    if [info exists dic($n)] {return $dic($n)}
    foreach {value word} {1000000 million 1000 thousand 100 hundred} {
        if {$n>=$value} {
            return "[en:num $n/$value] $word [en:num $n%$value 1]"
        }
    } ;#--------------- composing between 13 and 99...
    if $n>=20 {
        set res $dic([expr $n/10])ty
        if  $n%10 {append res -$dic([expr $n%10])}
    } else {
        set res $dic([expr $n-10])teen
    } ;#----------- fix over-regular compositions
    regsub "twoty" $res "twenty" res
    regsub "threet" $res "thirt" res
    regsub "fourty"  $res  "forty"  res
    regsub "fivet"  $res  "fift"  res
    regsub  "eightt"   $res  "eight" res
    return $res
  }
  proc s {n {w 0}} {
    concat [expr $n?"[en:num $n]":"no more"]\
            bottle[expr $n!=1?"s":""] of beer\
            [expr $w?" on the wall":{}]
  }
  proc string:title s {
    return [string toupper [string index $s 0]][string range $s 1 end]
  } ;#--- can be done with [string totitle since 8.1.1 ---
  
  proc bob {n} {if $n {subst "
 [string:title [s $n 1]], [s $n].
 Take [expr $n>1?{one}:{it}] down, pass it around,
 [s [incr n -1] 1].\n[bob $n]"} else {subst "
 Go to the store, buy some more, 
 [s 99 1]."}}

 puts [bob 99]

If not for the fun, this seems to be a good playground on which to
compare languages, and exercise a language to its limits ;-)
----
[Peter Lewerin] would do it this way... no, wait, '''this''' way -- no, actually I'd do it this way, I think:

 set bottle(s) bottles
 set n 99

 proc take args {
     puts [concat take $args]
 }

 proc (n) {b args} {
     puts [concat $::n [set ::$b] $args]
 }

 proc (n-1) {b args} {
     global n
     incr n -1
     if {$n == 1} {
         set bottle(s) bottle
     } else if {$n == 0} {
         set n "no more"
     }
     puts [concat $n [set ::$b] $args]\n
 }

 while {$n ne "no more"} {
     (n) bottle(s) of beer on the wall
     (n) bottle(s) of beer
     take one down, pass it around
     (n-1) bottle(s) of beer on the wall
 }
----
Similar, but a fall-through:

 set text "\$N bottle(s) of beer on the wall take one down, pass it around,"

 set N 100
 set n [ list 0 6 , 0 3 . 7 end ]

 while { $N } {
   set sing [ subst $text ]
   foreach [ list i j k ] $n {
      puts [ lrange $sing $i $j ]$k
   }
   incr N -1
   set sing [ subst $text ]
   puts "[ lrange $sing 0 6 ].\n"
 }

 puts "No more bottles of beer on the wall ;^("

NOTE: The above is NOT good. It is ''bottles'' for everything over 1 and ''bottle'' for the last one.

----
[glennj] a very compact version using variable write traces:
 proc setBottles {varName args} {
     upvar #0 $varName n
     set ::bottles [format "%d bottle%s" $n [expr {$n == 1 ? "" : "s"}]]
 }
   
 trace add variable i write setBottles
   
 for {set i 99} {$i > 0} {} {
     puts "$bottles of beer on the wall"
     puts "$bottles of beer"
     puts "take one down, pass it around"
     incr i -1
     puts "$bottles of beer on the wall\n"
 }
See also http://www.rosettacode.org/wiki/99_Bottles_of_Beer
----
Here's a mug of cyberbeer in Tk:
 pack [canvas .c]
 .c create rectangle 10 20 70 100 -fill gray95
 .c create arc 50 30 90 75 -start 90 -extent -180 \
        -style arc -width 10 -outline gray95
 .c create oval 15 10 65 30 -fill white -outline white
 .c create rectangle 15 20 65 85 -fill yellow
 .c create text 40 50 -text CYBER -fill red 
Enjoy! -- Didn't PSE once write:
''Tcl... the beer of languages... goes well with a BLT...''
----
For a poem on other drinks, see [Super and Subscripts in a text widget]
----
tcl is dynamic! 
 pack [canvas .c]
 .c create rectangle 10 20 70 100 -fill gray95
 .c create arc 50 30 90 75 -start 90 -extent -180 \
        -style arc -width 10 -outline gray95
 .c create oval 15 10 65 30 -fill white -outline white -tags {foam content}
 .c create rectangle 15 20 65 85 -fill {}       -tags {front}
 .c create rectangle 15 20 65 85 -fill yellow   -tags {beer content}
 .c create text 40 50 -text CYBER -fill red     -tags {front}

 proc drink {} {
        after 1000 drink
        .c scale content 40 85 1.0 0.9
        .c raise foam
        .c raise front
 }
 
 drink ;# prost, UK
----
[wdb] To be honest -- it turns me sad to watch the beer vanish ...
----
[Arts and crafts of Tcl-Tk programming] [Category Toys]