if 0 {
 [A text adventure game engine]
 [Larry Smith] 5-27-2008 
 }

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

########################################################################################
# End of Engine.  Below is demo adventure.

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


<<categories>> Games