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)

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

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