99 bottles of beer

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)

this site

, historically located at

,by Tim Robinson, with 227 programming languages, and then at ls-la.net

), exhibits a collection of presently 1500 programming languages

Tcl is represented there with 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 ;-)

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
}

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"
}

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

sergiol I had posted a golfed version to https://codegolf.stackexchange.com/a/109818/29325

proc B i {set x " bottle[expr $i>1?{s}:{}] of beer"}
set w " on the wall"
set i 99
while \$i>1 {puts "$i[B $i]$w, $i[B $i].\nTake one down and pass it around, [incr i -1][B $i]$w."}
puts "1[B $i]$w, 1[B $i].\nGo to the store and buy some more, 99[B 9]$w."

Category Toys

Category RosettaCode

Arts and crafts of Tcl-Tk programming