''From a news:comp.lang.tcl posting by mailto:larry@smith-house.org :''

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