Version 16 of A text adventure game engine

Updated 2008-05-26 21:29:04 by jscottb

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?

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

Scott Beasley 2008-05-26: This was a weekend project from about 8 years ago. It's an ALMOST working Scott Adams Text adventure [L1 ] game interpreter. I hope someone will find some good in it. Enjoy.


Game Parser Engine:

# TclAdamsEng.tcl # # Package to play Scott Adams Adventure game files in the TRS-80 format # (ScottFree). # # Author: Scott Beasley ([email protected]) # Feel free to *itch, or send patches to the above address :-) #

# Declare and build some "noseeums" for the game. set dirs {N NO NOR NORTH\

          S SO SOU SOUTH\
          E EA EAS EAST\
          W WE WES WEST\
          U UP\
          D DO DOW DOWN}

# Used to map direction letter to noun number. set dirmap {N 0 S 1 E 2 W 3 U 4 D 5} set dirnames list NORTH SOUTH EAST WEST UP DOWN

proc GetRandomNumber { } {

   set inum [expr {int (rand()*101)}]
   return $inum

}

# Clean-up game dB read data. proc Clean {args} {

   foreach argval $args {
      upvar $argval ptr
      set ptr [string trim $ptr {" }]
   }      

}

# Read in all chars from a file, between two '"' # Note: This is a quick hack at it, feel free to replace :-) proc ReadQuotedMsg {fd} {

   set msg_buff {}
   set QuoteCnt 0

   set char {}   
   while {1} {
      if {$char == {"}} {
         incr QuoteCnt
         if {$QuoteCnt == 2} {
            break   
         }            
      } else {
         append msg_buff $char         
      }

      set char [read $fd 1]
   }

   return $msg_buff

}

proc CountCarriedInv {strGameInfo} {

   upvar $strGameInfo GameInfo

   set indx 0   
   foreach item_info $GameInfo(items) {
      if {[lindex $item_info 1] == -1} {
         incr indx         
      }
   }

   return $indx   

}

# Return the verb number for a given verb string. proc GetVerbNo {strGameInfo verb} {

   upvar $strGameInfo GameInfo

   set verb_no 0
   set found_one 0

   set verb [string range $verb 0 [expr {$GameInfo(WordLen)-1}]]

   foreach verb_noun $GameInfo(words) {
      set WasSynonym 0
      set game_verb [lindex $verb_noun 0]
      if {[string index $game_verb 0] != "*"} {
         set curr_verb_no $verb_no
      } else {
        set game_verb [string range $game_verb 1 end]
        set WasSynonym 1         
      }         

      if {$verb == $game_verb} {
         set found_one 1
         if {$WasSynonym} {
            set verb_no $curr_verb_no
         }

         break   
      }

      incr verb_no
   }

   if {!$found_one} {
      return -1   
   }

   return $verb_no    

}

# Return the noun number for a given noun string. proc GetNounNo {strGameInfo noun} {

   upvar $strGameInfo GameInfo

   set noun_no 0
   set found_one 0

   set noun [string range $noun 0 [expr {$GameInfo(WordLen)-1}]]

   foreach verb_noun $GameInfo(words) {
      set WasSynonym 0
      set game_noun [lindex $verb_noun 1]
      if {[string index $game_noun 0] != "*"} {
         set curr_noun_no $noun_no
      } else {
         set game_noun [string range $game_noun 1 end]
         set WasSynonym 1         
      }

      if {$noun == $game_noun} {
         set found_one 1         
         if {$WasSynonym} {
            set noun_no $curr_noun_no
         }

         break   
      }

      incr noun_no
   }

   if {!$found_one} {
      return -1   
   }

   return $noun_no    

}

proc Look {strGameInfo} {

   upvar $strGameInfo GameInfo
   global dirnames

   set room $GameInfo(CurrentRoom)

   # Get exits to location...
   set room_info [lindex $GameInfo(locations) $room]
   set GameInfo(RoomText) [lindex $room_info 6]
   if {[string index $GameInfo(RoomText) 0] == "*"} {
      set GameInfo(RoomText) [string range $GameInfo(RoomText) 1 end]
   }

   set dirs [lrange $room_info 0 5]
   set dir_txt {}    
   set dir_ndx 0   
   foreach dir $dirs {
      if {$dir != 0} {
         append dir_txt "[lindex $dirnames $dir_ndx] "
      }

      incr dir_ndx      
   }

   set GameInfo(RoomExits) $dir_txt

   # Get Items at location...
   set GameInfo(ItemsInRoom) {}
   foreach item_info $GameInfo(items) {
      if {[lindex $item_info 1] == $room} {
         set item_desc [lindex [split [lindex $item_info 0] {/}] 0]
         lappend GameInfo(ItemsInRoom) $item_desc
      }      
   }

   return 0   

}

proc ItemLocationChange {strGameInfo item_no room} {

   upvar $strGameInfo GameInfo

   set item_info [lindex $GameInfo(items) $item_no]
   set GameInfo(items) [lreplace $GameInfo(items) $item_no \
                       $item_no [list [lindex $item_info 0] $room\
                       [lindex $item_info 2]]]

}

proc GetOrDrop {strGameInfo action item {static_ignore {}}} {

   upvar $strGameInfo GameInfo
   set iRet 4

   # This will let us match it from the noun part of the table
   # And handle the user typing syn's also.
   set noun_ndx [GetNounNo GameInfo $item]
   if {$noun_ndx > -1} {
      set item [lindex [lindex $GameInfo(words) $noun_ndx] 1]
   }

   # Get...   
   if {!$action} {      
      set item_ndx 0      
      foreach item_info $GameInfo(items) {
         set item_desc [lindex [split [lindex $item_info 0] {/}] 0]
         set item_name [string trim [lindex [split [lindex \
                        $item_info 0] {/}] 1]]
         set item_loc [lindex $item_info 1]         

         if {($item_name == $item && $item_loc == $GameInfo(CurrentRoom))} {
            if {[CountCarriedInv GameInfo] >= $GameInfo(MaxItemsCarry)} {
               set iRet 10
               break               
            }

            # Is the item static?         
            if {$item_name == ""} {
               if {$static_ignore == ""} {               
                  set iRet 5
               }

               break            
            }

            # See if we have it already...            
            if {$item_loc == -1} {
               set iRet 6
               break            
            }               

            set iRet 0
            ItemLocationChange GameInfo $item_ndx -1
            break            
         }

         incr item_ndx
      }      
   }

   # Drop...
   if {$action} {      
      set item_ndx 0      
      foreach item_info $GameInfo(items) {
         set item_desc [lindex [split [lindex $item_info 0] {/}] 0]
         set item_name [string trim [lindex [split [lindex \
                        $item_info 0] {/}] 1]]
         set item_loc [lindex $item_info 1]

         # Yet another hack fix.... 
         # Doing this helps with Items that have the same name.
         # Pirate's Cove was really bad about this.         
         if {$item_loc == 0} {
            incr item_ndx
            continue
         }

         if {$item_name == $item} {
            if {$item_loc == -1} {            
               set iRet 0
               ItemLocationChange GameInfo $item_ndx $GameInfo(CurrentRoom)
               break
            } else {
               set iRet 9
               break            
            }               
         }

         incr item_ndx
      }      
   }

   return $iRet

}

proc MoveInDirection {strGameInfo dir_no} {

   upvar $strGameInfo GameInfo

   set room_info [lindex $GameInfo(locations) $GameInfo(CurrentRoom)]
   set room [lindex $room_info $dir_no]
   if {$room} {
      set GameInfo(CurrentRoom) $room
   } else {
      return 3      
   }      

   return 0   

}

proc CheckConditions {strGameInfo conds_lst} {

   upvar $strGameInfo GameInfo

   # Clear the param list here.   
   set GameInfo(param_lst) {}

   foreach condition $conds_lst {
      set cond 1      
      set cond_val [expr {$condition%20}]
      set arg_val [expr {$condition/20}]      

      # Check for one of 19 condition types.      
      switch $cond_val {
         0 {
            lappend GameInfo(param_lst) $arg_val
         }

         1 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] != -1} {
               set cond 0
            }           
         }            

         2 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] != $GameInfo(CurrentRoom)} {
               set cond 0
            }
         }            

         3 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] != $GameInfo(CurrentRoom) && \
                [lindex $item_info 1] != -1} {
               set cond 0
            }           
         }            

         4 {
            if {$arg_val != $GameInfo(CurrentRoom)} {
               set cond 0
            }           
         }            

         5 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] == $GameInfo(CurrentRoom)} {
               set cond 0
            }           
         }            

         6 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] == -1} {
               set cond 0
            }           
         }            

         7 {
            if {$arg_val == $GameInfo(CurrentRoom)} {
               set cond 0
            }           
         }            

         8 {
            if {!$GameInfo(Flag-$arg_val)} {
               set cond 0
            }               
         }            

         9 {
            if {$GameInfo(Flag-$arg_val)} {
               set cond 0
            }
         }            

         10 {
            if {![CountCarriedInv GameInfo]} {
               set cond 0
            }               
         }            

         11 {
            if {[CountCarriedInv GameInfo]} {
               set cond 0
            }               
         }            

         12 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] == $GameInfo(CurrentRoom) || \
                [lindex $item_info 1] == -1} {
               set cond 0
            }           
         }            

         13 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {![lindex $item_info 1]} {
               set cond 0
            }           
         }            

         14 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1]} {
               set cond 0
            }           
         }            

         15 {
            if {[CountCarriedInv GameInfo] > $arg_val} {
               set cond 0
            }               
         }            

         16 {
            if {[CountCarriedInv GameInfo] <= $arg_val} {
               set cond 0
            }               
         }            

         17 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] != [lindex $item_info 2]} {
               set cond 0
            }           
         }            

         18 {
            set item_info [lindex $GameInfo(items) $arg_val]
            if {[lindex $item_info 1] == [lindex $item_info 2]} {
               set cond 0
            }           
         }            

         19 {
            if {$GameInfo(CurrentCounter) != $arg_val} {
               set cond 0      
            }               
         }         
      }

      if {!$cond} {
         set GameInfo(ConditionFailed) 1
         break      
      } else {
         set GameInfo(ConditionFailed) 0         
      }         
   }

   return $cond

}

proc DoActions {strGameInfo action_lls} {

   upvar $strGameInfo GameInfo

   set GameInfo(param_ndx) 0    
   foreach action $action_lls {
      if {!$action} {
         continue
      }

      # Append any msg's to the current msg list.
      if {$action >= 1 && $action < 52} {
         lappend GameInfo(CurrentMsgs) [lindex $GameInfo(messages) $action]
         continue         
      }         

      if {$action > 101} {
         lappend GameInfo(CurrentMsgs) [lindex $GameInfo(messages) \
                 [expr {$action-50}]]
         continue                        
      }

      set arg_param [lindex $GameInfo(param_lst) $GameInfo(param_ndx)]
      # See if it was another type of action.            
      switch $action {
         52 {
            if {[CountCarriedInv GameInfo] >= $GameInfo(MaxItemsCarry)} {
               lappend GameInfo(CurrentMsgs) "You are carrying to much!\n"
               break               
            }

            ItemLocationChange GameInfo $arg_param -1
            incr GameInfo(param_ndx)
            set GameInfo(DidGetOrDrop) 1
         }            

         53 {
            ItemLocationChange GameInfo $arg_param $GameInfo(CurrentRoom)
            incr GameInfo(param_ndx)
            set GameInfo(DidGetOrDrop) 1
         }

         54 {
            set GameInfo(CurrentRoom) $arg_param
            incr GameInfo(param_ndx)
         }            

         55 -
         59 {         
            ItemLocationChange GameInfo $arg_param 0
            incr GameInfo(param_ndx)
         }            

         56 {
            set GameInfo(IsDark) 1
            set GameInfo(Flag-15) 1
         }            

         57 {
            set GameInfo(IsDark) 0
            set GameInfo(Flag-15) 0
         }            

         58 -
         60 {
            set GameInfo(Flag-$arg_param) [expr {$action==60?0:1}]
            incr GameInfo(param_ndx)
         }            

         61 {
            set GameInfo(IsDead) 1
            set GameInfo(IsDark) 0
            set GameInfo(Flag-15) 0
            set GameInfo(CurrentRoom) [expr {$GameInfo(NumberOfRooms)-1}]
         }

         62 {
            incr GameInfo(param_ndx)
            set iroom [lindex $GameInfo(param_lst) $GameInfo(param_ndx)]
            ItemLocationChange GameInfo $arg_param $iroom
            incr GameInfo(param_ndx)
         }

         63 {
            set GameInfo(GameOver) 0
            if {$GameInfo(GameOverFunc) != ""} {
               eval $GameInfo(GameOverFunc)
            }
         }

         64 -
         76 {
            if {$GameInfo(LookFunc) != ""} {
               eval $GameInfo(LookFunc)
            }
         }            

         65 {
            set iTreasureCnt 0
            foreach item_info $GameInfo(items) {
               if {([lindex $item_info 1] == $GameInfo(TreasureRoom)) && \
                   [string index [lindex $item_info 0] 0] == "*"} {
                  incr iTreasureCnt
               }                  
            }

            set iScore [expr {$iTreasureCnt*100/$GameInfo(TotalTreasures)}]

            if {$GameInfo(TotalTreasures) == $iTreasureCnt} {
               lappend GameInfo(CurrentMsgs) "\nYou Win!"
            }

            lappend GameInfo(CurrentMsgs) "\nYou have stored away\
                    $iTreasureCnt of $GameInfo(TotalTreasures) total\
                    treasures." "Your score is $iScore."
         }

         66 {
            lappend GameInfo(CurrentMsgs) "\nYou are carrying:"
            if {![CountCarriedInv GameInfo]} {
               lappend GameInfo(CurrentMsgs) "Nothing."
            }

            set iLineLen 0
            set iDivder 0
            set InvLine {}                  
            foreach item_info $GameInfo(items) {
               if {[lindex $item_info 1] != -1} {
                  continue
               }

               set item [lindex [split [lindex $item_info 0] {/}] 0]               
               append InvLine "$item. "

               if {[expr {$iLineLen+[string length $item]+2}] >= \
                   $GameInfo(MaxDisplayWidth)} {
                  lappend GameInfo(CurrentMsgs) "$InvLine\n"
                  set iLineLen 0
                  set InvLine {}                  
               }

               incr iLineLen [expr {[string length $item]+2}]
            }

            lappend GameInfo(CurrentMsgs) "$InvLine\n"
         }

         67 {
            set GameInfo(Flag-0) 1
         }

         68 {
            set GameInfo(Flag-0) 0
         }

         69 {
            set GameInfo(LightCountDown) $GameInfo(TotalLightTime)
            # Item number 9 is always the light source.
            ItemLocationChange GameInfo 9 -1            
            set GameInfo(IsDark) 0
            set GameInfo(Flag-15) 0
         }

         70 {

# set GameInfo(CurrentMsgs) {}

            if {$GameInfo(ClearFunc) != ""} {
               eval $GameInfo(ClearFunc)
            }
         }

         71 {
            if {$GameInfo(SaveGameFunc) != ""} {
               eval $GameInfo(SaveGameFunc)
            }
         }

         72 {
            set item_no1 $arg_param
            incr GameInfo(param_ndx)
            set item_no2 [lindex $GameInfo(param_lst) $GameInfo(param_ndx)]
            set item_loc1 [lindex [lindex $GameInfo(items) $item_no1] 1]
            set item_loc2 [lindex [lindex $GameInfo(items) $item_no2] 1]
            ItemLocationChange GameInfo $item_no1 $item_loc2
            ItemLocationChange GameInfo $item_no2 $item_loc1
            incr GameInfo(param_ndx)
         }

         73 {
            set GameInfo(Continue) 1
         }

         74 {
            ItemLocationChange GameInfo $arg_param -1
            incr GameInfo(param_ndx)
         }

         75 {
            set item_no1 $arg_param
            incr GameInfo(param_ndx)
            set item_no2 [lindex $GameInfo(param_lst) $GameInfo(param_ndx)]
            set item_loc2 [lindex [lindex $GameInfo(items) $item_no2] 1]
            ItemLocationChange GameInfo $item_no1 $item_loc2
            incr GameInfo(param_ndx)
         }

         77 {
            if {$GameInfo(CurrentCounter) >= 0} {
               incr GameInfo(CurrentCounter) -1
            }
         }

         78 {
            lappend GameInfo(CurrentMsgs) $GameInfo(CurrentCounter)
         }

         79 {
            set GameInfo(CurrentCounter) $arg_param
            incr GameInfo(param_ndx)
         }

         80 {
            set iSwap $GameInfo(RoomNumberHold)
            set GameInfo(RoomNumberHold) $GameInfo(CurrentRoom)
            set GameInfo(CurrentRoom) $iSwap
         }

         81 {
            set iSwap $GameInfo(CurrentCounter)
            set GameInfo(CurrentCounter) $GameInfo(Counter-$arg_param)
            set GameInfo(Counter-$arg_param) $iSwap
            incr GameInfo(param_ndx)
         }

         82 {
            incr GameInfo(CurrentCounter) $arg_param
            incr GameInfo(param_ndx)
         }

         83 {
            set arg_val "-$arg_param"
            incr GameInfo(CurrentCounter) $arg_val
            incr GameInfo(param_ndx)
         }

         84 {
            lappend GameInfo(CurrentMsgs) $GameInfo(TypedNoun)
         }

         85 {
            lappend GameInfo(CurrentMsgs) $GameInfo(TypedNoun) "\n"
         }

         86 {
            lappend GameInfo(CurrentMsgs) "\n"
         }

         87 {
            set iSwap $GameInfo(CurrentRoom)
            set GameInfo(CurrentRoom) $GameInfo(RoomStack-$arg_param)
            set GameInfo(RoomStack-$arg_param) $iSwap
            incr GameInfo(param_ndx)
         }

         88 {
            after 2000
         }

         89 {
            incr GameInfo(param_ndx)
         }
      }
   }

}

proc CheckActions {strGameInfo verb_no noun_no} {

   upvar $strGameInfo GameInfo
   set repeat 0
   set iWasAction 0

   # Clear the param list counter here.   
   set GameInfo(param_ndx) 0

   # Loop all the actions in the list and see if we have a hit.   
   foreach action_info $GameInfo(actions) {
      set vocab [lindex $action_info 0]
      set action_verb [expr {$vocab/150}]
      set action_noun [expr {$vocab%150}]
      set cond1 [lindex $action_info 1]
      set cond2 [lindex $action_info 2]
      set cond3 [lindex $action_info 3]
      set cond4 [lindex $action_info 4]
      set cond5 [lindex $action_info 5]

      if {($action_verb == $verb_no || !$action_verb) || ($repeat && !$action_verb)} {
         if {($action_noun == $noun_no || !$action_noun) || !$action_verb} {
            # Code for conditions that are only checked n% of the time.            
            if {(!$action_verb && \
                ([GetRandomNumber] >= $action_noun)) && !$repeat} {
               continue                   
            }

            set condition [CheckConditions GameInfo [list $cond1 $cond2 \
                                           $cond3 $cond4 $cond5]]

            if {$condition} {
               set action1 [lindex $action_info 6]
               set action2 [lindex $action_info 7]
               set act0 [expr {$action1/150}]
               set act1 [expr {$action1%150}]
               set act2 [expr {$action2/150}]
               set act3 [expr {$action2%150}]

               DoActions GameInfo [list $act0 $act1 $act2 $act3]
               set iWasAction 1
               # I guess this is right?               
               if {$GameInfo(Continue)} {               
                  set GameInfo(Continue) 0
                  set repeat 1                  
               }

               if {$action_verb && !$repeat} {
                  break
               }         
            }               
         }
      }

      if {$action_verb} {
         set repeat 0   
      }         
   }

   return $iWasAction

}

proc ParseUserInput {strGameInfo cmdln_in} {

   upvar $strGameInfo GameInfo
   global dirs dirmap

   set iVerbNo -1
   set iNounNo 0
   set iGetAll 0
   set iret 0
   set GameInfo(TypedNoun) {}
   set GameInfo(ConditionFailed) 0   
   set GameInfo(DidGetOrDrop) 0
   set GameInfo(WasHelp) 0
   incr GameInfo(TurnCnt)
   if {!$GameInfo(LightCountDown)} {
      set GameInfo(IsDark) 1
      set GameInfo(Flag-15) 1
      return 11      
   } else {
      incr GameInfo(LightCountDown) -1
   }      

   foreach {verb noun} [string trim [split $cmdln_in]] {}
   set GameInfo(TypedNoun) $noun
   set verb [string toupper $verb]   
   set noun [string toupper $noun]   

   if {$verb == {QUIT} || $verb == {EXIT} || $verb == {Q}} {
      set GameInfo(Playing) 0
      if {$GameInfo(GameOverFunc) != ""} {
         eval $GameInfo(GameOverFunc)
      }

      return 0
   }

   set iVerbNo [GetVerbNo GameInfo $verb]

   # Check and see if it was a direction.   
   if {$iVerbNo == 1 && $noun == ""} {
      return 2     
   }

   if {$iVerbNo == 1 || $noun == ""} {
      if {$noun != ""} {
         set possiable_dir $noun
      } else {
         set possiable_dir $verb
      }         

      foreach dir [string trim [split $dirs]] {
         if {$possiable_dir == $dir} {
            set dir [string range $possiable_dir 0 0]
            set iVerbNo 1
            set iNounNo [string map $dirmap $dir]
            set iret [MoveInDirection GameInfo $iNounNo]
         }         
      }
   }

   # Extra hack for 'Inventory'.
   if {$verb == {I}} {
      set iVerbNo [GetVerbNo GameInfo "INV"]
   }

   # Extra hack for get/drop all.
   if {($iVerbNo == 10 || $iVerbNo == 18) && $noun == "ALL"} {
      set iGetAll 1      
   }

   # Check for unknown command, or match a noun if there was one.
   if {$iVerbNo == -1} {
      return 7
   } else {
      if {$noun != "" && !$iGetAll} {
         set iNounNo [GetNounNo GameInfo $noun]
         if {$iNounNo == -1} {
            return 8
         }
      }
   }

   # Check for any actions to perform.   
   set iWasAction [CheckActions GameInfo $iVerbNo $iNounNo]

   if {$verb == "HELP" && !$GameInfo(ConditionFailed)} {
      set GameInfo(WasHelp) 1
      if {$GameInfo(HelpFunc) != ""} {
         eval $GameInfo(HelpFunc)
      }
   }

   # See if it was a 'GET' or 'DROP'.   
   if {($iVerbNo == 10 || $iVerbNo == 18) && \
      !$GameInfo(DidGetOrDrop) && $GameInfo(ConditionFailed)} {
      if {$noun == "ALL"} {
         foreach item_info $GameInfo(items) {
            if {[lindex $item_info 1] != $GameInfo(CurrentRoom)} {
               continue
            }
            set item [string trim [lindex [split [lindex \
                           $item_info 0] {/}] 1]]
            set iret [GetOrDrop GameInfo [expr {$iVerbNo==10?0:1}] $item 1]
            if {!$iret} {
               set item_desc [string trim [lindex [split [lindex \
                             $item_info 0] {/}] 0]]
               lappend GameInfo(CurrentMsgs) "$item_desc: O.K."
            }               
         }            
      } else {
         set iret [GetOrDrop GameInfo [expr {$iVerbNo==10?0:1}] $noun]
      }

      # Hackish way to get certain events to happen.
      # Maybe not the best place for it, but....      
      CheckActions GameInfo $iVerbNo $iNounNo
   }

   return $iret

}

proc ReadAdventureFile {strGameInfo gamefile} {

   upvar $strGameInfo GameInfo
   unset GameInfo

   # Init the game play vars.
   set GameInfo(datfile) $gamefile
   set GameInfo(Playing) 1
   set GameInfo(GameOver) 0
   set GameInfo(Continue) 0
   set GameInfo(IsDark) 0
   set GameInfo(IsDead) 0
   set GameInfo(TurnCnt) 0
   set GameInfo(param_lst) {}
   set GameInfo(param_ndx) 0
   set GameInfo(BitFlags) 0
   set GameInfo(CurrentCounter) 0
   set GameInfo(CurrentMsgs) {}
   set GameInfo(CurrentUserMsgs) {}
   set GameInfo(TypedNoun) {}
   set GameInfo(RoomNumberHold) 0
   set GameInfo(DidGetOrDrop) 0
   set GameInfo(WasHelp) 0
   set GameInfo(SaveGameFunc) {}
   set GameInfo(ClearFunc) {}
   set GameInfo(LookFunc) {}
   set GameInfo(GameOverFunc) {}   
   set GameInfo(HelpFunc) {}
   set GameInfo(MaxDisplayWidth) 80
   set GameInfo(ConditionFailed) 0

   # I go a little more on the counters and flags just for the future.
   for {set iNdx 0} {$iNdx < 32} {incr iNdx} {
      set GameInfo(Counter-$iNdx) 0
   }

   # I do the flags like this... Because I can :-).
   for {set iNdx 0} {$iNdx < 32} {incr iNdx} {
      set GameInfo(Flag-$iNdx) 0
   }

   for {set iNdx 0} {$iNdx < 32} {incr iNdx} {
      set GameInfo(RoomStack-$iNdx) 0
   }

   set fd [open $GameInfo(datfile) "r"]
   fconfigure $fd -buffersize 256000

   # Read in the Game file info, and store it.   
   set filler [gets $fd]
   set GameInfo(NumberOfItems) [string trim [gets $fd]]
   set GameInfo(NumberOfActions) [string trim [gets $fd]]
   set GameInfo(NumberOfWords) [string trim [gets $fd]] 
   set GameInfo(NumberOfRooms) [string trim [gets $fd]]
   set GameInfo(MaxItemsCarry) [string trim [gets $fd]]
   set GameInfo(StartingRoom) [string trim [gets $fd]]
   set GameInfo(TotalTreasures) [string trim [gets $fd]]
   set GameInfo(WordLen) [string trim [gets $fd]]
   set GameInfo(TotalLightTime) [string trim [gets $fd]]
   set GameInfo(NumberOfMsgs) [string trim [gets $fd]]
   set GameInfo(TreasureRoom) [string trim [gets $fd]]
   set GameInfo(CurrentRoom) $GameInfo(StartingRoom)
   set GameInfo(LightCountDown) $GameInfo(TotalLightTime)

   set ActCnt 0
   incr GameInfo(NumberOfActions)   
   while {$ActCnt < $GameInfo(NumberOfActions)} {
      set Vocab [gets $fd]
      set Condition1 [gets $fd]; set Condition2 [gets $fd]
      set Condition3 [gets $fd]; set Condition4 [gets $fd]
      set Condition5 [gets $fd]
      set Action1 [gets $fd]; set Action2 [gets $fd]
      Clean Vocab Condition1 Condition2 Condition3 \
            Condition4 Condition5 Action1 Action2      
      lappend GameInfo(actions) [list $Vocab $Condition1 $Condition2\
                                      $Condition3 $Condition4\
                                      $Condition5 $Action1 $Action2]
      incr ActCnt                                
   }

   set WordCnt 0
   incr GameInfo(NumberOfWords)   
   while {$WordCnt < $GameInfo(NumberOfWords)} {
      set Verb [gets $fd]; set Noun [gets $fd]
      Clean Verb Noun      
      lappend GameInfo(words) [list $Verb $Noun]
      incr WordCnt                                
   }

   set RoomCnt 0
   incr GameInfo(NumberOfRooms)
   while {$RoomCnt < $GameInfo(NumberOfRooms)} {
      set Exit1 [gets $fd]; set Exit2 [gets $fd]
      set Exit3 [gets $fd]; set Exit4 [gets $fd]
      set Exit5 [gets $fd]; set Exit6 [gets $fd]
      set Desc [ReadQuotedMsg $fd]
      # Eat the extra space and nl after the room txt.      
      gets $fd
      Clean Exit1 Exit2 Exit3 Exit4 Exit5 Exit6 Desc

      lappend GameInfo(locations) [list $Exit1 $Exit2 $Exit3\
                                        $Exit4 $Exit5 $Exit6 $Desc]
      incr RoomCnt
   }

   set MsgCnt 0
   incr GameInfo(NumberOfMsgs)   
   while {$MsgCnt < $GameInfo(NumberOfMsgs)} {
      set msg [ReadQuotedMsg $fd]
      Clean msg
      lappend GameInfo(messages) $msg
      incr MsgCnt                                
   }

   set ItemCnt 0
   incr GameInfo(NumberOfItems)
   while {$ItemCnt < $GameInfo(NumberOfItems)} {
      set Item [ReadQuotedMsg $fd]
      set Location [gets $fd]
      Clean Item Location
      lappend GameInfo(items) [list $Item $Location $Location]
      incr ItemCnt                                
   }

   set ActCnt 0
   while {$ActCnt < $GameInfo(NumberOfActions)} {
      set ActionCmd [ReadQuotedMsg $fd]
      Clean ActionCmd
      lappend GameInfo(actioncmds) [string trim $ActionCmd "\n\r"]
      incr ActCnt                                
   }   

}


Text based driver:

#!/bin/sh # \ exec tclsh "$0" $@

# TclAdams.tcl # # Txt Driver to test Scott Adams Adventure game engine written in TCL. # # Author: Scott Beasley ([email protected]) # Feel free to *itch, or send patches to the above address :-) #

source TclAdamsEng.tcl

# Test it all out with a puny little driver.

   set GameInfo {}

   if {$argc < 1} {
     puts "We need a game file to play!\nUsage:\
           TclAdams gamedatfile"
     exit 1           
   } else {
     set GameFile [lindex $argv 0]      
   }      

   ReadAdventureFile GameInfo $GameFile
   fconfigure stdout -buffering none

   CheckActions GameInfo 0 0

   while {$GameInfo(Playing)} {
      puts "*******************************************"
      Look GameInfo
      foreach msg $GameInfo(CurrentMsgs) {
         set msg [string trimright $msg "\n"]
         if {$msg != ""} {         
            puts $msg
         }            
      }

      puts "\nLocation:\n$GameInfo(RoomText)"
      set iLineLen 0
      set iDivder 0
      if {[llength $GameInfo(ItemsInRoom)]} {   
         puts -nonewline "You see: "
         foreach item $GameInfo(ItemsInRoom) {
            if {$iDivder} {
               puts -nonewline " - "   
            } else {
               set iDivder 1         
            }         

            if {[expr {$iLineLen+[string length $item]+3}] >= 70} {
               puts ""
               set iLineLen 0
            }

            incr iLineLen [expr {[string length $item]+3}]
            puts -nonewline $item
         }
      }

      puts "\nObvious exits: $GameInfo(RoomExits)\n"

      while 1 {
         puts -nonewline "What do you want to do? "         
         set cmd_ln [string trim [gets stdin]]
         puts {}
         if {$cmd_ln != ""} {
            break      
         }      
         puts "Pardon?\n"
      }

      set GameInfo(CurrentMsgs) {}
      if {$cmd_ln == ""} {
         continue      
      }

      set iRet [ParseUserInput GameInfo $cmd_ln]

      switch $iRet {
         2 {
            puts "You must supply a direction.\n"
         }

         3 {
            puts "You can't go in that direction.\n"
         }

         5 {
            puts "It's beyond your power to do that!\n"
         }

         6 {
            puts "You are carring that already...\n"
         }

         7 {
            puts "You speak unknown words!\n"
         }

         8 {
            puts "Don't know what that is?\n"
         }

         9 {
            puts "You are not carring that...\n"
         }

         10 {
            puts "You are carring to much!\n"
         }

         11 {
            puts "It's too dark to do it!\n"
         }
      }
   }

# puny driver end.


Gui based Driver:

#!/bin/sh # \ exec wish "$0" $@

# TkAdams.tcl # # Tk driver to test Scott Adams Adventure game engine written in TCL. # # Author: Scott Beasley ([email protected]) # Feel free to *itch, or send patches to the above address :-) #

source TclAdamsEng.tcl

proc LoadAdventFile {{GameFile {}}} {

   global GameInfo   

   set GameInfo(MaxDisplayWidth) 85   
   if {$GameFile == ""} {
      set types {
          {{Adams Games Files}   {.dat}  TEXT}
          {{All Files}         *             }
      }

      set filename [tk_getOpenFile -filetypes $types]

      if {$filename != ""} {
         set GameFile $filename
      }
   }

   if {$GameFile != ""} {
      ReadAdventureFile GameInfo $GameFile
      CheckActions GameInfo 0 0
      MakeAWish 1
      focus .fr_one_wish.e_command   
   }

}

proc UserError {errormsg} {

   .fr_one.txt_action_msgs configure -state normal   
   .fr_one.txt_action_msgs delete 1.0 end
   .fr_one.txt_action_msgs insert 1.0 $errormsg
   .fr_one.txt_action_msgs configure -state disabled

}

proc DescriptPuts {line} {

   .fr_one.txt_room_and_item_info configure -state normal
   .fr_one.txt_room_and_item_info insert end $line
   .fr_one.txt_room_and_item_info configure -state disabled

}

proc ActionPuts {line} {

   set line [string trimright $line]
   .fr_one.txt_action_msgs configure -state normal   
   .fr_one.txt_action_msgs insert end $line
   .fr_one.txt_action_msgs insert end "\n"
   .fr_one.txt_action_msgs configure -state disabled

}

proc SetDirButtonsAllowed {} {

   global GameInfo dirnames

   foreach dir $dirnames {
      ".fr_two.b_[string tolower $dir]" configure -state disabled      
   }

   if {[string trim $GameInfo(RoomExits)] != ""} {
      foreach dir [split $GameInfo(RoomExits)] {
         if {[string trim $dir] != ""} {
            ".fr_two.b_[string tolower $dir]" configure -state active
         }            
      }
   }      

}

proc MakeAWish {{noparse 0}} {

   global UsersWish GameInfo

   if {$noparse} {
      set iRet 0      
   } else {
      set GameInfo(CurrentMsgs) {}
      set UsersWish [string trim $UsersWish]
      if {$UsersWish == ""} {
         return         
      }

      set iRet [ParseUserInput GameInfo $UsersWish]
   }

   set UsersWish {}
   Look GameInfo

   .fr_one.txt_action_msgs configure -state normal
   .fr_one.txt_room_and_item_info configure -state normal
   .fr_one.txt_action_msgs delete 1.0 end
   .fr_one.txt_room_and_item_info delete 1.0 end
   .fr_one.txt_action_msgs configure -state disabled
   .fr_one.txt_room_and_item_info configure -state disabled

   switch $iRet {
      2 {
         UserError "You must supply a direction.\n"
      }

      3 {
         UserError "You can't go in that direction.\n"
      }

      5 {
         UserError "It's beyond your power to do that!\n"
      }

      6 {
         UserError "You are carring that already...\n"
      }

      7 {
         UserError "You speak unknown words!\n"
      }

      8 {
         UserError "Don't know what that is?\n"
      }

      9 {
         UserError "You are not carring that...\n"
      }

      10 {
         UserError "You are carring to much!\n"
      }

      11 {
         UserError "It's too dark to do it!\n"
      }
   }

   set iFirstActMsg 0   
   foreach msg $GameInfo(CurrentMsgs) {
      if {!$iFirstActMsg} {
         set msg [string trimleft $msg "\n"]
         set iFirstActMsg 1   
      }

      set msg [string trimright $msg "\n"]
      if {$msg != ""} {         
         ActionPuts "$msg\n"
      }            
   }

   DescriptPuts "You are in a $GameInfo(RoomText)\n"
   set iLineLen 0
   set iDivder 0
   if {[llength $GameInfo(ItemsInRoom)]} {   
      DescriptPuts "You see: "
      foreach item $GameInfo(ItemsInRoom) {
         if {$iDivder} {
            DescriptPuts ". "
         } else {
            set iDivder 1         
         }         

         if {[expr {$iLineLen+[string length $item]+2}] >= \
             $GameInfo(MaxDisplayWidth)} {
            DescriptPuts "\n"
            set iLineLen 0
         }

         incr iLineLen [expr {[string length $item]+2}]
         DescriptPuts $item
      }
   }

# DescriptPuts "\nObvious exits: $GameInfo(RoomExits)\n"

   SetDirButtonsAllowed   

}

proc DoDirection {dir} {

   global UsersWish

   set UsersWish $dir
   MakeAWish   

}

# TkAdams Driver.

   # Build the window.
   wm title . {tkAdams}
   wm resizable . 0 0
   wm deiconify .

   frame .fr_one -borderwidth 0 -height 75 -relief groove -width 340 
   text .fr_one.txt_action_msgs -height 10 -state disabled
   text .fr_one.txt_room_and_item_info -height 10 -state disabled
   frame .fr_one_wish -borderwidth 0 -height 75 -relief groove -width 340 
   label .fr_one_wish.l_your_wish -borderwidth 1 -relief flat \
         -text {What is your wish?} -width 18 
   entry .fr_one_wish.e_command -textvariable UsersWish -width 25

   grid .fr_one -in . -column 0 -row 3 -columnspan 1 -rowspan 1 
   grid .fr_one.txt_action_msgs -in .fr_one -column 0 -row 2 \
        -columnspan 1 -rowspan 1 
   grid .fr_one.txt_room_and_item_info -in .fr_one -column 0 -row 3 \
        -columnspan 1 -rowspan 1 
   grid .fr_one_wish -in .fr_one -column 0 -row 4 -columnspan 1 -rowspan 1 
   grid .fr_one_wish.l_your_wish -in .fr_one_wish -column 0 -row 0 \
        -columnspan 1 -rowspan 1 
   grid .fr_one_wish.e_command -in .fr_one_wish -column 1 -row 0 \
        -columnspan 1 -rowspan 1 

   frame .fr_two -borderwidth 0 -height 75 -relief groove -width 125
   grid .fr_two -in . -column 0 -row 4 -columnspan 1 -rowspan 1
   set colndx 1
   foreach dir $dirnames {
      button ".fr_two.b_[string tolower $dir]" -text $dir \
             -command "DoDirection $dir" -width 8 -state disabled
      grid ".fr_two.b_[string tolower $dir]" -in .fr_two -column $colndx \
           -row 1 -columnspan 1 -rowspan 1
      incr colndx         
   }      

   frame .fr_three -borderwidth 0 -height 75 -relief groove -width 200
   grid .fr_three -in . -column 0 -row 5 -columnspan 1 -rowspan 1
   button .fr_three.b_quit -text "Quit" \
          -command "exit" -width 8 -state normal
   button .fr_three.b_save -text "Save Game" -padx 10 \
          -command "SaveGame" -width 8 -state normal
   button .fr_three.b_load_game -text "Load Game" -padx 10 \
          -command "SaveGame" -width 8 -state normal
   button .fr_three.b_load -text "Load New Adventure" -padx 40 \
          -command "LoadAdventFile" -width 8 -state normal
   grid .fr_three.b_quit -in .fr_three -column 0 \
        -row 5 -columnspan 1 -rowspan 1
   grid .fr_three.b_save -in .fr_three -column 2 \
        -row 5 -columnspan 1 -rowspan 1 -sticky nsew
   grid .fr_three.b_load_game -in .fr_three -column 3 \
        -row 5 -columnspan 1 -rowspan 1 -sticky nsew
   grid .fr_three.b_load -in .fr_three -column 4 \
        -row 5 -columnspan 2 -rowspan 1 -sticky nsew

   bind .fr_one_wish.e_command <Key-Return> "MakeAWish"

   set GameFile {}      
   if {$argc >= 1} {
      set GameFile [lindex $argv 0]      
   }

   LoadAdventFile $GameFile   

# end TkAdams



Category Games