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.
if 0 {
[A text adventure game engine]
[Scott Beasley] 2008-05-26
}
# Game Engine - Save as TclAdamsEng.tcl
#############################################################################
## 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