From a news:comp.lang.tcl posting by mailto:[email protected] :
webscool wrote:
> Has anyone written a pure Tcl/Tk engine for text based adventure games?
Toyed with one. It provides for a number of text-based adventure game "chores" including defining rooms and characters, building a vocabulary, clothes, etc. Here is the basic engine, followed by a moronic little space- adventure that shows how it works. It's GPL, and it will be easier to read with a wide window.
proc ins { list args } {
upvar #0 $list which
eval lappend which $args
puts "Exit to where?"
}
}
define { foreach { fname body } $args {
set fname [ string trim $fname ]
eval ins ObjFuncs($name) $fname
uplevel #0 proc $name-$fname "args" \{$body\}
}
}
do { set fname [lindex $args 0]
set args [ lrange $args 1 end ]
if { "[ info procs $name-$fname ]" != "" } {
return [ eval uplevel #0 $name-$fname $args ]
} else {
return 0
}
}
default { puts "message $func $args not understood by $name" ; exit }
}
}
#################################################################
# tiny little space adventure to test out above
#################################################################
proc vacuum { args } {
if { [ me: has_on spacesuit ] } { return }
puts "There is vacuum here - and you are not wearing a spacesuit. You die."
exit
}
object bridge new -desc {bridge of the ship} -attrs {place} -exits {passageway} -article the
object passageway new -desc {small room aft of the bridge} -attrs {place} -exits {bridge airlock}
object outside new -desc {outside the ship} -attrs {place} -article ""
object airlock new -desc {airlock} -exits {passageway} -has {switch} -attrs {place} -article an
object sphere new -desc {silvery sphere} -where {bridge} -attrs {place !move}
object laser new -desc {laser} -where {bridge} -define {
use {
if { ! [ accessable me laser ] } {
"You can't use it if you aren't holding it."
return 0
}
set location [ me: where ]
foreach item $args {
if { "$item" == "" } { return }
if { "$item" == "laser"} {
puts "The laser cannot shoot itself."
return 0
}
if { ("$item" != "on") && ("$item" != "at") } {
if { [ me: hasobjs $item ] } {
me: drop $item
}
if { [ [ me: where ]: hasobjs $item ] } {
puts "$item destroyed"
$location: remobjs $item
return 1
} else {
puts "I see no $item here."
return 0
}
}
}
}
}
set airlock_switch 0
object switch new -desc {switch} -attrs {!move} -where {airlock} -define {
use {
global airlock_switch
if { ! [ accessable me switch ] } {
puts "You can't use the switch if you aren't near it."
return 0
}
puts "The airlock cycles."
if { $airlock_switch } {
puts "The air rushes in."
set airlock_switch 0
passageway: addexits airlock
outside: remexits airlock
airlock: addexits passageway
airlock: remexits outside
airlock: remattrs vacuum
} else {
puts "The air rushes out."
set airlock_switch 1
passageway: remexits airlock
outside: addexits airlock
airlock: remexits passageway
airlock: addexits outside
airlock: addattrs vacuum
}
look
return 1
}
}
object jumper new -desc {ship's jumper} -attrs {wear}
object spacesuit new -desc {standard-issue spacesuit} -attrs wear -where airlock
object me new -where bridge -don jumper -define {
moveto {
if { "$args" == "outside" } {
me: setstate ""
} elseif { ("[ me: where ]" == "outside") && ("$args" == "airlock") } {
me: setstate " in"
}
return 0
}
}
####################################################################
proc look { } {
puts ""
puts -nonewline "You are"
me: state
[ me: where ]: describe
puts -nonewline "."
set inv [ [ me: where ]: getobjs ]
set me [ lsearch $inv me ]
set inv [ lreplace $inv $me $me ]
set len [ llength $inv ]
if { $len > 0 } {
puts -nonewline " There is"
set first 1
incr len -1
for { set i 0 } { $i <= $len } { incr i } {
set curitem [ lindex $inv $i ]
if { !$first } {
if { "$i" == "$len" } {
puts -nonewline " and"
} else {
puts -nonewline ", "
}
}
set first 0
$curitem: describe
}
puts -nonewline " here."
}
set exits [ [ me: where ]: getexits ]
set numexits [ llength $exits ]
puts -nonewline " "
if { $numexits == 0 } {
puts -nonewline "There are no exits." ; return
} elseif { $numexits == 1 } {
puts -nonewline "There is an exit to the "
} else {
puts -nonewline "There are exits to the "
}
set first 1
foreach i $exits {
if { !$first } { puts -nonewline ", " }
set first 0
puts -nonewline "$i"
}
puts "."
}
proc go { where } {
me: moveto $where
look
}
proc enter { where } {
me: enter $where
look
}
proc exit { } {
me: exit
look
}
proc take { args } {
me: take $args
}
proc drop { args } {
me: drop $args
}
proc inventory { } {
set inv [ me: getobjs ]
if { "$inv" != "" } {
puts -nonewline "You are carrying: "
set first 1
foreach i $inv {
if { !$first } { puts -nonewline ", " }
set first 0
$i: describe
}
puts "."
} else {
puts "You are carrying nothing."
}
set inv [ me: wearing ]
if { "$inv" != "" } {
puts -nonewline "You are wearing "
set first 1
foreach i $inv {
if { !$first } { puts -nonewline ", " }
set first 0
$i: describe
}
puts "."
} else {
puts "You are wearing nothing."
}
}
proc examine { what } {
$what: describe
}
proc use { what args } {
if { ![ $what: do use $args ] } {
puts "I see no point to that."
}
}