[Richard Suchenwirth] 1999-07-21:   I much too late discovered the "99 bottles
of beer" game, where the text of the admittedly silly song

======none
99 bottles of beer on the wall, 99 bottles of beer.
Take one down, pass it around,
98 bottles of beer.
... (downto 0)
======

[http://www.99-bottles-of-beer.net/%|%this site], historically located at
[http://www.westnet.com/mirrors/99bottles/beer.html%|westnet.com%|%] ,by Tim
Robinson, with 227 programming languages,  and then at
[http://internet.ls-la.net/mirrors/99bottles/%|%ls-la.net]), exhibits a
collection of presently 1500 programming languages

Tcl is represented there with
[http://www.99-bottles-of-beer.net/language-tcl-439.html%|%a program] by [Don
Libes] ,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 ;-)

----
[PL] 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} {
    incr ::n -1
    set ::bottle(s) [expr {$::n != 1 ? "bottles" : "bottle"}]
    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
}
======

[PL]: (update 2013-12-30) changed the `(n-1)` command.  It used to have an `[if]` that didn't work, at least not in Tcl 8.6 (did `else if` work back in Tcl 8.4? because I ''did'' run the code at least once to test it back then).  Also, pluralization didn't actually work as intended, but that would have been me being insufficiently attentive, unfortunately.  The two middle lines in the updated version are less verbose, express the logic better and with more coverage, and last but not least: now they work.  I was tempted to make another change to replace the single line in the `take` command with `puts [[info level 0]]` which prints the same thing (at least until such time as the output format of `[info level]` gets changed), but that would be overdoing it.

----
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 ...

<<categories>> Toys | RosettaCode | Arts and crafts of Tcl-Tk programming