''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?

[Larry Smith]
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.

The parser is dead simple - a verb, and an object, just
like the original Colossal Cave adventure. I've fixed a
few bugs - the engine no longer crashes if it doesn't
recognize your verb.  There was a problem with re-defining
"exit" - now if you die in the airlock the interpreter
exits, rather than recursing into a vain attempt to leave
an airlock.  The "exit" verb is now gone, you can "enter"
things, but you must provide exits inside them to get back
out.

The vocabulary is limited but you can accomplish a surprising
amount of stuff using it, with a little imagination.  The
highly generic "use" verb helps avoid a lot of vocabulary
clutter and "guess the verb" games.

 proc ins { list args } {
  upvar #0 $list which

  eval lappend which $args
 }

 proc rem { list args } {
  upvar #0 $list which

  foreach item $args {
    switch -regexp -- $item {
      \[-0-9\]\[0-9\]* { set which [ lreplace $which $item $item ] }
      default           { set this [ lsearch $which $item ]
                          if { $this != -1 } {
                            set which [ lreplace $which $this $this ]
                          }
                        }
    }
  }
 }

 proc accessable { obj1 obj2 } {
  if { [ object $obj1 where ] == [ object $obj2 where ] } { return 1}
  if { [ object $obj1 hasobjs $obj2 ] } { return 1 }
  return 0
 }

 proc object { name func args } {
  global ObjDesc ObjAttrs ObjContents ObjFuncs ObjExits ObjWears ObjLoc ObjArticle ObjState

  if { "$name" == "" } { return }
  switch -exact -- $func {
     new      { set ObjDesc($name) ""
                set ObjAttrs($name) ""
                set ObjContents($name) ""
                set ObjFuncs($name) ""
                set ObjExits($name) ""
                set ObjLoc($name) ""
                set ObjState($name) "in"
                set ObjArticle($name) "a"
                foreach { i j } $args {
                  switch -exact -- $i {
                    -desc     { eval object $name setdesc $j }
                    -attrs    { eval object $name addattrs $j }
                    -contents { eval object $name insobjs $j }
                    -where    { eval object $j insobjs $name ; set ObjLoc($name) $j }
                    -exits    { eval object $name addexits $j }
                    -don      { eval set ObjWears($name) $j }
                    -define   { eval object $name define $j }
                    -article  { set ObjArticle($name) $j }
                    -state    { set ObjState($name) $j }
                  }
                }
                set body "eval object $name \$args"
                proc $name: "args" "$body"
              }
    setstate  { eval set ObjState($name) $args    }
    state     { puts -nonewline $ObjState($name)  }
    article   { if ![string equal $ObjArticle($name) "" ] {
                  puts -nonewline "$ObjArticle($name) "
                }
	      }
    setdesc   { set ObjDesc($name) "$args"        }
    describe  { if ![string equal $ObjArticle($name) "" ] {
                  puts -nonewline "$ObjArticle($name) $ObjDesc($name)"
	        } else {
                  puts -nonewline "$ObjDesc($name)"
		}
	      }
    addexits  { eval ins ObjExits($name) $args    }
    remexits  { eval rem ObjExits($name) $args    }
    getexits  { return $ObjExits($name)           }
    hasexits  { foreach i $args { if { [ lsearch $ObjExits($name) $i ]  == -1 } { return 0 } }
                return 1
              }
    addattrs  { eval ins ObjAttrs($name) $args
                foreach i $args { if { "[ info procs $i ]" != "" } { $i $name $ObjLoc($name) } }
              }
    remattrs  { eval rem ObjAttrs($name) $args
                foreach i $args { if { "[ info procs $i ]" != "" } { $i $name $ObjLoc($name) } }
              }
    getattrs  { return ObjAttrs($name)            }
    hasattrs  { foreach i $args { if { [ lsearch $ObjAttrs($name) $i ]  == -1 } { return 0 } }
                return 1
              }
    insobjs   { eval ins ObjContents($name) $args }
    remobjs   { eval rem ObjContents($name) $args }
    getobjs   { return $ObjContents($name)        }
    hasobjs   { foreach i $args { if { [ lsearch $ObjContents($name) $i ]  == -1 } { return 0 } }
                return 1
              }
    where     { return $ObjLoc($name)             }
    take      { if { [ object $name do take $args ] } { return }
                foreach i $args {
                  if { [ object $ObjLoc($name) hasobjs $i ] } {
                    if { [ object $i hasattrs !move ] } {
                      puts "You can't take the $i."
                    } else {
                      object $ObjLoc($name) remobjs $i
                      object $name insobjs $i
                      puts "$i taken"
                    }
                  } else {
                    if { [ object $i hasattrs place ] } {
                      object $name moveto $i
                    } else {
                      puts "I see no $i here."  
                    }
                  }
                }
              }
    drop      { if { [ object $name do drop $args ] } { return }
                foreach i $args {
                  if { [ object $name hasobjs $i ] } {
                    if { [ object $i hasattrs !move ] } {
                      puts "You can't drop the $i."
                    } else {
                      object $name remobjs $i
                      object $ObjLoc($name) insobjs $i
                      puts "$i dropped."
                    }
                  } else {
                    puts "I see no $i here."  
                  }
                }
              }
    don       { if { [ object $name do don $args ] } { return }
                foreach i $args {
                 if { [ object $ObjLoc($name) hasobjs $i ] } { object $name take $i }
                 if { [ object $name hasobjs $i ] } {
                    if { [ object $i hasattrs wear ] } {
                      ins ObjWears($name) $i
                      rem ObjContents($name) $i
                      puts "You are now wearing a $i."
                    } else {
                      puts "Okay, how, exactly, do I wear a $i?"
                    }
                 } else {
                   puts "I don't see a $i here."
                 }
                }
              }
    doff      { if { [ object $name do doff $args ] } { return }
                foreach i $args {
                  if { [ object $name has_on $i ] } {
                    rem ObjWears($name) $i
                    ins ObjContents($name) $i
                    puts "$i removed."
                  } else {
                    puts "You aren't wearing a $i."
                  }
                }
              }
    wearing   { return $ObjWears($name) }
    has_on    { foreach i $args { if { [ lsearch $ObjWears($name) $i ] != -1 } { return 1 } }
                return 0
              }
    moveto    { if { [ object $name do moveto $args ] } { return }
                set exit [ lindex $args 0 ]
                if { [ object $ObjLoc($name) hasexits $exit ] } {
                  object $ObjLoc($name) remobjs $name
                  set ObjLoc($name) $exit
                  object $ObjLoc($name) insobjs $name
                } elseif { [ object $ObjLoc($name) hasobjs $exit ] } {
                  object $name enter $exit
                } else {
                  return
                }
                foreach i [ object [ object $name where ] getattrs ] {
                  if { "[ info procs $i ]" != "" } {
                    $i $name $ObjLoc($name)
                  }
                }
              }
    enter     { if { [ object $name do enter $args ] } { return }
                set what [ lindex $args 0 ]
                if { [ object $name hasobjs $what ] } {
                  puts "How can you enter that?"
                  return
                }
                if { [ object $ObjLoc($name) hasobjs $what ] } {
                  if { [ object $what hasattrs place ] } {
                    object $ObjLoc($name) remobjs $name
                    set ObjLoc($name) $what
                    object $ObjLoc($name) insobjs $name
                  } else {
                    puts -nonewline "How, exactly, do you climb into "
                    object $what describe
                    puts "?"
                  }
                } else {
                  return "I see no $what here."
                }
              }
    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 }
  }
 }

########################################################################################

 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} -exits {bridge}

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

 # The vocabulary
 proc use { what args } {
  if { ![ $what: do use $args ] } {
    puts "I see no point to that."
  }
 }

 proc don { what args } {
  me: don $what
 }

 proc doff { what args } {
  me: doff $what
 }

 proc bye { args } {
  exit
 }

 look
 while 1 {
  puts -nonewline ">>> " ; flush stdout
  if [ catch [ gets stdin ] err ] {
    puts "I didn't understand that."
  }
 }



----
[Category Games]

Suggest some easy [http://www.usfine.com WoW Powerleveling] service

Or someone can try this useful [http://www.usfine.com/World-of-Warcraft-US-Pl-c-53.html WoW Powerleveling] links