[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 ;-)

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

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