proc s {n} {concat $n bottle[expr $n>1?"s":""] of beer}
proc bob {n} {if $n {return "
[s $n] on the wall, [s $n].
Take one down, pass it around,
[s [incr n -1]].
[bob $n]"}}
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 -- and could
also bring some diversion into comp.lang.tcl, besides exec "ls *.c"
problems ;-)
--
Schoene Gruesse/best regards, Richard Suchenwirth -- tel. +49-7531-86
2703
> RC DT2, Siemens Electrocom GmbH, Buecklestr. 1-5, D-78467 Konstanz, Germany
> My opinions were not necessarily, or will not necessarily be, mine.
One minor nit to pick: it generates:
0 bottle of beer
so I changed it a little:
proc s {n} {concat $n bottle[expr $n>1||$n==0?"s":""] of beer}
proc bob {n} {if $n {return "
etc.
Nice.
--
Stefaan
--
PGP key available from PGP key servers (http://www.pgp.net/pgpnet/)
___________________________________________________________________
Perfection is reached, not when there is no longer anything to add,
but when there is no longer anything to take away. -- Saint-Exupéry
>so I changed it a little:
>
>proc s {n} {concat $n bottle[expr $n>1||$n==0?"s":""] of beer}
gnurk....
proc s {n} {concat $n bottle[expr {$n-1?{s}:{}}] of beer}
I don't think you're *supposed* to be cryptic.
proc s {n} {concat $n bottle[expr {$n!=1?{s}:{}}] of beer}
--
Darren New / Senior Software Architect / MessageMedia, Inc.
San Diego, CA, USA (PST). Cryptokeys on demand.
There is no "best" programming language. Only "least worst."
Oh what fun :-)
Here's 11 characters trimmed off, but it probably doesn't work
in tcl7.5 because of the "subst" which was worth one character
over "return". I didn't actually save anything with "if"
instead of "expr", but it looks less like line noise.
proc s n {concat $n bottle[if $n-1 {list s}] of beer}
proc b n {if $n {subst "
[s $n] on the wall, [s $n].
Take one down, pass it around,
[s [incr n -1]].
[b $n]"}}
b 99
John Ellson
# Bottles of Tcl beer, by: Richard Suchenwirth and others on comp.lang.tcl
proc s n {concat $n bottle[if $n-1 {list s}] of beer};proc b n {if $n {subst "
[s $n] on the wall, [s $n].\nTake one down, pass it around,\n[s [incr n -1]].
>I don't think you're *supposed* to be cryptic.
>proc s {n} {concat $n bottle[expr {$n!=1?{s}:{}}] of beer}
well, if we're into shortness like the other branch of this thread is, that was
worth a point.
--
<URL:http://www.glinx.com/~hclsmith/>
of course, by that defense, i should strip off a pair of braces. and surely we
can do something with that concat...
--
<URL:http://www.glinx.com/~hclsmith/>
Good for a signature, but I think it couldn't impress a Perlist - and
someone who is to maintain that code. After reading dozens of 99BoB
implementations, I noticed that the spec is not exactly tight, but quite
some authors added features:
- "0 bottles" spelled as "No more bottles"
- when only 1 bottle left, "Take it down" instead of "Take one down"
- the last line of each verse should again end with "on the wall"
- added an ultimate (cyclic) verse about buying more beer
- plus many specials (e.g. in Ada, Expect)
So here's my v2.3:
proc s {n {w 0}} {
concat [expr $n?$n:"no more"] bottle[expr $n!=1?"s":""] of beer\
[expr $w?" on the wall":{}]
}
proc b {{n 99}} {if $n {subst "
[s $n 1], [s $n].\nTake [expr $n>1?{one}:{it}] down, pass it around,
[s [incr n -1] 1].\n[b $n]"} else {subst "
[s 0 1], [s 0].\nGo to the store, buy some more, [s 99 1]."}}
You should also check out the Expect version at the same web site. It
simulates a human typing "99 bottles ..." while drinking 99 bottles.
As the drinking progresses, the typing becomes more erratic both in
terms of speed and spelling errors. And sometimes, it entirely loses
its place. (My chance to show off the "send -h" feature.)
Don
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 "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]
}
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]
An adaption and extension of Richard's to add the ability to have
it give the numbers in roman numerals, with 8.1.1 string features:
proc roman {x args} {
set result ""
foreach elem {
{ 1000 M } { 900 CM } { 500 D } { 400 ID }
{ 100 C } { 90 IC } { 50 L } { 10 X }
{ 9 IX } { 5 V } { 4 IV } { 1 I }
} {
set digit [lindex $elem 0]
set roman [lindex $elem 1]
while {$x >= $digit} {
append result $roman
incr x -$digit
}
}
return $result
}
proc english {n {optional 0}} {
#---------------- English spelling for integer numbers
if {$optional && $n==0} {return ""}
if {![info exists ::dic]} {
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
}
set ::map [list twoty twenty threet thirt fivet fift eightt eight \
fourty forty]
}
if {[info exists ::dic($n)]} {return $::dic($n)}
foreach {value word} {1000000 million 1000 thousand 100 hundred} {
if {$n >= $value} {
return "[english [expr {$n/$value}]]\
$word [english [expr {$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
return [string map $::map $res]
}
proc s {t n {w 0}} {
return "[expr {$n?[$t $n $w]:{no more}}] bottle[expr {$n!=1?{s}:{}}]\
of beer[expr {$w?{ on the wall}:{}}]"
}
proc bob {n {t english}} {if {$n>0} {return "
[expr {[string eq roman $t]?[s $t $n 1]:[string tot [s $t $n 1]]}], [s $t
$n].
Take [expr {$n>1?{one}:{it}}] down, pass it around,
[s $t [incr n -1] 1].\n[bob $n $t]"} else {return "
Go to the store, buy some more,\n[s $t 99 1]."}}
** Jeffrey Hobbs jeff.hobbs @SPAM acm.org **
** I'm really just a Tcl-bot My opinions are MY opinions **
proc morse {s} {
global _morse
if ![info exists _morse] {
set _morse {
A ._ Ä ._._ B _... C _._. D _.. E . F .._.
G __. H .... I .. J .___ K _._ L ._.. M __
N _. O ___ Ö ___. P .__. Q __._ R ._. S ...
T _ U .._ Ü ..__ V ..._ W .__ X _.._ Y _.__ Z __..
0 _____ 1 .____ 2 ..___ 3 ...__ 4 ...._ 5 .....
6 _.... 7 __... 8 ___.. 9 ____.
}
}
set res ""
if [regexp {^[._ ]+$} $s] {
regsub -all { +} $s " B " s
foreach i [split $s] {
if {$i==""} continue
if {$i=="B"} {append res " "; continue}
set ix [lsearch $_morse $i]
if $ix>=0 {
append res [lindex $_morse [expr $ix-1]]
} else {append res ?}
}
} else {
foreach i [split [string toupper $s] ""] {
if {$i==""} continue
if {$i==" "} {append res " "; continue}
set ix [lsearch $_morse $i]
if $ix>=0 {
append res "[lindex $_morse [expr $ix+1]] "
}
}
}
return $res
}
Just for impressing people, one could translate the 99 bottles, with
Roman numerals, to morse...
puts [morse [bob 99]]