home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.wwiv.com
/
ftp.wwiv.com.zip
/
ftp.wwiv.com
/
pub
/
MISC
/
DNDOOR45.ZIP
/
DNDS2.BAS
< prev
next >
Wrap
BASIC Source File
|
2000-04-28
|
121KB
|
2,671 lines
Rem * Filename: dnds2.bas Version: v4.5 r1.0
Rem * This subprogram contains most login routines, and parse routines.
Rem $Include: 'dnddoor.inc'
Rem * routine to login user.
Rem * output variables:
Rem * Time.On - contains time logged in.
Rem * Timeon - contains time logged in past midnight.
Rem * Time.Left - stores time limit in seconds past midnight.
Rem * User.Index - number of record in user file codename will use.
Rem * processing variables:
Rem * Time.Left - during logging in.
Rem * Two.Minutes.Left - time remaining flag.
Rem * Login.Try - total login attempts.
Rem * New.User - flag indicates new user login.
Rem * Logged.User - flag indicates user exists in files.
Sub Login
On Local Error Resume Next ' local error resume
Time.On=Time$ ' store system time logged in (string form hh:mm:ss)
Timeon=Timer ' store system time logged in (seconds past midnight)
Timelogged.On=Now ' store time logged in (double format)
Time.Left=600! ' set time limit during logging in
Two.Minutes.Left=False ' flag for two minute left display message
Logged.In=False ' set user logged in flag
' format initial login display line
Outpt="The Adventure Door v"+Version$+", Node: "+Node+", "+FNclock$
If Local.Mode=False Then
Outpt=Outpt+", baud"+Str$(Modem.Baud)+"00"
Endif
Outpt=Outpt+"."
Call IO.O ' display initial message
' format prompt for login welcome
Outpt="Press <enter> to display the welcome, or <space> to skip:"
No.Echo=True ' supress prompt input echo
Line.Length=1 ' get only one keypress
Call IO.I ' input routine
No.Echo=False ' reset echo
If Inpt=Nul Then ' check empty return
Call Out.File("welcome.dat") ' display welcome file
Endif ' end display welcome
Do ' main login processing loop
Login.Try=False ' reset login attempts
Do ' get codename processing loop
New.User=False ' reset new user flag
Call Get.Codename ' prompt user for codename
Call Get.PassWord ' prompt user for password
Call Find.PassWord(Logged.User) ' find codename in user file
If Logged.User Then ' compare user has entered an existing codename
Call Verify.PassWord(Logged.Pass) ' compare entered password
If Logged.Pass Then ' check if password matches
Exit Do ' exit codename processing/entry loop
Endif ' end check password match
If Login.Try>=3 Then ' compare login attempts
Call Hang.Up(7) ' routine to terminate program w/ message
Exit Sub ' exit login routine/return to main
Endif ' end compare login attempts
Login.Try=Login.Try+1 ' increment login attempt
Outpt="Illegal password attempt!" ' display error message
Call IO.O ' send output/continue codename entry loop
Else ' user has not entered an existing codename
Call Get.Newuser.Record ' find an empty user file record
Call Verify.Newuser(New.User) ' verify password entered
If New.User>False Then ' user selected disconnect
Call Hang.Up(8) ' routine to terminate program w/ message
Exit Sub ' exit routine
Endif ' end compare disconect
If New.User<False Then ' user password verified
Call Init.Newuser ' initialize some new user variables
Call Verify.Newlogin(New.User,True) ' verify user is new
If New.User Then ' user selects to continue as a new user
Exit Do ' exit codename/password entry loop
Endif ' end new user continue
Endif ' end password verify
Endif ' end compare existing codename
Loop ' codename/password entry loop
Call Update.Login ' intialize some login variables
If New.User=False Then ' compare user is new user
Exit Do ' exit main login processing loop
Endif ' end compare new user
If New.User Then ' compare new user login is verified
Call Roll.Character ' get user selected character statistics
Call Verify.Newlogin(New.User,False) ' verify new user to continue
If New.User Then ' new user is logged in
Exit Do ' exit main login processing loop
Endif ' end compare new user login
Endif ' end compare new user login
Loop ' end main login processing loop
Call Login.User ' routine to initialize some login variables
Outpt=Nul ' send empty output
Call IO.O ' send output
Outpt="Press <enter> to begin the adventure:" ' format message
No.Echo=True ' set flag to supress echo input
Line.Length=1 ' get one keypress
Call IO.I ' get input
No.Echo=False ' reset echo flag
Next.Room=Room ' store room number
Call Enter.Room ' display room description
Logged.In=True ' set user logged in flag
Func.Buffer=Nul ' reset function key flag
End Sub ' end routine to login user
Rem * routine to find codename entered in user file.
Rem * output variables:
Rem * PassWord.Found - flag if codename is in user file.
Sub Find.PassWord(PassWord.Found)
On Local Error Resume Next ' local error resume
PassWord.Found=False ' set flag to false
Inpt=Rtrim$(Player.CodeName) ' store codename
For User.Index=1 To Lof(UserFile)/Len(UserRecord) ' loop through entire user file
Call Read.Record(UserFile,User.Index) ' get next user file record
Outpt=UserRecord.CodeName ' store user file codename
Call Decrypt(Outpt) ' decrypt user file codename
Outpt=Rtrim$(Outpt) ' trim user file codename
If Outpt=Inpt Then ' compare user file codename to codename entered
PassWord.Found=True ' set return variable flag
Exit For ' exit user file loop
Endif ' end check codenames
Next ' loop through user file
End Sub ' end routine to find user file codename
Rem * routine to verify valid password of codename entered.
Rem * output variables:
Rem * PassWord.Found - flag indicates password exists.
Sub Verify.PassWord(PassWord.Found)
On Local Error Resume Next ' local error resume
PassWord.Found=False ' set flag to false
Outpt=UserRecord.PassWord ' store user file password
Call Decrypt(Outpt) ' decrypt password
If Len(Outpt)=False Then ' verify decrypt result
Outpt="Password has a checksum error!" ' format message
Call IO.O ' send message
PassWord.Found=False ' set flag to verify password
Exit Sub ' exit check password routine
Endif ' end check password
Outpt=Rtrim$(Outpt) ' store trimmed user file password
Inpt=Rtrim$(Player.PassWord) ' store password entered
If Outpt=Inpt Then ' compare user file password to entered password
PassWord.Found=True ' set flag to verify password
Endif ' end compare passwords
End Sub ' end routine to check valid password
Rem * routine to verify new user is continuing.
Rem * input variables:
Rem * Message.Type - message to select.
Rem * output variables:
Rem * Response.Type - returns true to continue, false if not.
Sub Verify.Newlogin(Response.Type,Message.Type)
On Local Error Resume Next ' local error resume
Do ' process input loop
Graphics.Off=False ' reset color
If Message.Type Then ' compare prompt
Outpt="Press <enter> to roll character, or <space> to reenter:"
Else ' select prompt
Outpt="Press <enter> to use character, or <space> to reroll:"
Endif ' end compare prompt
No.Echo=True ' supress input echo
Line.Length=1 ' input one keypress
Call IO.I ' get user input
No.Echo=False ' reset input echo
If Inpt=" " Then ' selected space
Response.Type=False ' set return flag
Exit Do ' exit routine
Endif ' end compare select
If No.Input Then ' compare empty input
Response.Type=True ' set return flag
Exit Do ' exit routine
Endif ' end compare select
Loop ' process input loop
End Sub ' end routine to prompt to continue
Rem * routine to get codename, check illegal character in codename, verify
Rem * user has entered correct codename.
Rem * output variables:
Rem * Player.CodeName - contains lowercased, trimmed codename entered.
Sub Get.Codename
On Local Error Resume Next ' local error resume
Do ' main codename entry processing loop
Do ' loop until valid codename entered
Outpt=Nul ' empty output
Call IO.O ' send output
Graphics.Off=True ' reset color
Outpt=" +---------+---------+---------+" ' make length bar
Call IO.O ' send output
Outpt="Codename? " ' codename prompt
Line.Length=30 ' set line length of codename
Upper.Case=True ' reset uppercase flag
Call IO.I ' get codename input
Upper.Case=False ' reset uppercase flag
Graphics.Off=False ' reset color
Inpt=Ltrim$(Inpt) ' trim blanks
Inpt=Rtrim$(Inpt) ' trim blanks
Inpt=Ucase$(Inpt) ' set input to uppercase
Player.CodeName=Inpt ' store codename
If Len(Player.CodeName)>False Then ' check length of codename
Call Valid(Player.CodeName,30) ' verify valid characters
If Len(Player.CodeName)>False Then ' check valid codename
Exit Do ' exit codename entry loop
Endif ' end check valid characters
Outpt="Illegal characters in codename!" ' format message
Call IO.O ' send output
Endif ' end check codename length
Loop ' continue entry loop
Outpt=Rtrim$(Player.CodeName) ' store codename
Outpt=Lcase$(Outpt) ' set to lowercase
Mid$(Outpt,1,1)=Ucase$(Mid$(Outpt,1,1)) ' make first character uppercase
Outpt="You are "+Chr$(34)+Outpt+Chr$(34)+"(y/n)? " ' format prompt
No.Input.Out="Y" ' set default input to yes
Line.Length=1 ' reset line length
Call IO.I ' prompt for correct codename entered
If Yes Then ' verify user has verified correct codename
Exit Do ' exit main codename entery loop
Endif ' end verify user input
Loop ' end codename entry loop
End Sub ' end routine to get and verify codename entry
Rem * routine to prompt user for password, check valid characters in password.
Rem * output variables:
Rem * Player.PassWord - contains lowercased, trimmed password entered.
Sub Get.PassWord
On Local Error Resume Next ' local error resume
Do ' password entry loop
Outpt=Nul ' empty output
Call IO.O ' send output
Graphics.Off=True ' reset color
Outpt=" +---------+---------+" ' make length bar
Call IO.O ' send output
Outpt="Password? " ' password prompt
Line.Length=20 ' set line length of password
Hidden=True ' set flag to echo mask characters
Call IO.I ' get input
Hidden=False ' reset mask flag
Graphics.Off=False ' reset color
Inpt=Ltrim$(Inpt) ' trim blanks
Inpt=Rtrim$(Inpt) ' trim blanks
Inpt=Ucase$(Inpt) ' set input to uppercase
Player.PassWord=Inpt ' store password
If Len(Player.PassWord)>False Then ' check length of password
Call Valid(Player.PassWord,20) ' verify valid characters
If Len(Player.PassWord)>False Then ' check valid password
Exit Do ' exit password entry loop
Endif ' end check valid characters
Outpt="Illegal characters in password!" ' format message
Call IO.O ' send output
Endif ' end check password length
Loop ' end password entry loop
End Sub ' end routine to enter password
Rem * routine to find empty user file record.
Rem * output variables:
Rem * User.Index - unused number of record in user file.
Sub Get.Newuser.Record
On Local Error Resume Next ' local error resume
For User.Index=1 To Lof(UserFile)/Len(UserRecord) ' loop through users
Call Read.Record(UserFile,User.Index) ' load the user record
Outpt=UserRecord.CodeName ' store user file codename
Call Decrypt(Outpt) ' routine to decrypt codename
If Left$(Outpt,9)=Deleted$ Then ' compare to deleted record
Exit For ' end loop through user file
Endif ' end compare deleted record
Next ' end loop through user file
' exit of loop w/o finding a deleted record will set User.Index to one
' record past the last in the user file, appending the next record.
Call Read.Record(UserFile,User.Index) ' get empty user file record
Outpt="Codename not found in files!" ' make message
Call IO.O ' send message
End Sub ' end routine to find empty user file record
Rem * routine to verify new user login.
Rem * output variables:
Rem * Response.Type - flag set to 1 to disconnect,
Rem * 0 if password not verified, -1 if password is verified.
Sub Verify.Newuser(Response.Type)
On Local Error Resume Next ' local error resume
Do ' password verify loop
Outpt="Press <C>ontinue, <H>angup, or <R>estart:" ' make message
No.Input.Out="C" ' default empty input to continue
Line.Length=1 ' reset line length
Call IO.I ' get input
Response.Type=False ' set return flag to unverified
Select Case Ucase$(Inpt) ' compare input selection
Case "C" ' continue selected
Outpt=Nul ' set empty output
Call IO.O ' send output
Outpt="Verify password: " ' prompt for password
Hidden=True ' set echo characters masked
Line.Length=20 ' line length of password
Call IO.I ' get user input
Hidden=False ' reset echo mask flag
Inpt=Ltrim$(Inpt) ' trim input
Inpt=Rtrim$(Inpt) ' trim input
Inpt=Ucase$(Inpt) ' set input uppercase
Outpt=Rtrim$(Player.PassWord) ' store password entered
If Outpt<>Inpt Then ' compare password entered to verify entry
Outpt="Passwords don't match!" ' make error message
Call IO.O ' send output
Response.Type=False ' set flag to unverified
Exit Do ' exit routine
Endif ' end compare password
Outpt="Memorize your password!" ' make message
Call IO.O ' send output
Call IO.O ' send empty line
Response.Type=True ' set flag to verified
Exit Do ' exit routine
Case "H" ' hangup selected
Response.Type=1 ' set flag to hangup user
Exit Do ' exit routine
Case "R" ' restart selected
Response.Type=False ' set flag to restart/unverified
Exit Do ' exit routine
End Select ' end compare input selection
Loop ' end password verify loop
End Sub ' end routine to verify new password
Rem * routine to allow user to select new character statistics.
Rem * processing variables:
Rem * Display.Help - flag to display login help messages.
Sub Roll.Character
On Local Error Resume Next ' local error resume
Display.Help=False ' set flag to display help text
Outpt="List help text during character logon(y/n)? " ' prompt for help
No.Input.Out="N" ' default prompt
Line.Length=1 ' reset line length
Call IO.I ' get user input
If Yes Then ' check input
Display.Help=True ' set help text flag
Endif ' end check input
If Display.Help Then ' check help flag
Call Logon.Help(1) ' display class help text
Endif ' end check help flag
Call Modify.Class ' routine to select class type
If Display.Help Then ' check help flag
Call Logon.Help(2) ' display statistics entry help text
Endif ' end check help flag
Call Modify.Stats ' routine to select character statistics
If Display.Help Then ' check help flag
Call Logon.Help(3) ' display race entry help text
Endif ' end check help flag
Call Modify.Race ' routine to select character race
Call Init.Race.Stats ' routine to initialize some race statistics
If Display.Help Then ' check help flag
Call Logon.Help(4) ' display weapon proficiency entry help text
Endif ' end check help flag
Call Modify.Proficiency ' routine to select weapon proficiency
Call Init.Proficiency.Stats ' routine to intialize proficiency statistics
Call Init.Stats ' routine to intialize some character statistics
If Display.Help Then ' check help flag
Call Logon.Help(5) ' display alignment entry help text
Endif ' end check help flag
Call Modify.Alignment ' routine to select character alignment
Call Display.Init.Stats ' routine to display character statistics
End Sub ' end routine to get new character statistics
Rem * routine to display help text.
Rem * input variables:
Rem * Help.Number - range of help text file records to display.
Rem * work variables:
Rem * Start.Help, End.Help, Help.Count.
Sub Logon.Help(Help.Number)
On Local Error Resume Next ' local error resume
Close #HelpFile ' close work file number
FileName="logon.dat" ' store logon helptext filename
Open FileName For Random Shared As #HelpFile Len=Len(HelpRecord) ' open file
Graphics.Off=True ' set color flag
Outpt=Nul ' send empty line
Call IO.O ' send output
Select Case Help.Number ' selection for logon help record ranges
Case 1 ' help records
Start.Help=2
End.Help=6
Case 2 ' help records
Start.Help=7
End.Help=15
Case 3 ' help records
Start.Help=16
End.Help=25
Case 4 ' help records
Start.Help=26
End.Help=32
Case 5 ' help records
Start.Help=33
End.Help=36
End Select ' end select record ranges
For Help.Count=Start.Help To End.Help ' loop through help text file range
Call Read.Record(HelpFile,Help.Count) ' read help record
Outpt=Rtrim$(HelpRecord.Text) ' format help text
Call IO.O ' send help output
Next 'end loop through help file
Call IO.O ' send ampty output
Call More.Prompt ' get keypress
Graphics.Off=False ' reset color flag
Close #HelpFile
End Sub ' end routine to display help text
Rem * routine to allow user to modify character alignment.
Sub Modify.Alignment
On Local Error Resume Next ' local error resume
Do ' process modify alignment one loop
Graphics.Off=False ' reset color
Outpt="Player Alignment:" ' make message
Call IO.O ' display message
Outpt="Press "+Enter$+" for default." ' make message
Call IO.O ' display message
Graphics.Off=True ' reset color
For Align.Count=1 To 3 ' display alignment choices
Outpt=Mid$(Str$(Align.Count),2)+"> "+ _
Rtrim$(Alignment.Name1(Align.Count))
Call IO.O ' send output
Next ' loop through alignment choices
Outpt="?" ' prompt for alignment number
No.Input.Out="2" ' default to neutral
Line.Length=1 ' reset line length
Call IO.I ' get input
Player.Alignment=Int(Val(Inpt)) ' convert to number
If Player.Alignment>=1 And Player.Alignment<=3 Then ' compare valid choice
Exit Do ' exit first loop
Endif ' end compare choice
Loop ' continue alignment loop
UserRecord.Align1=Player.Alignment-2 ' store alignment as -1/0/1
Do ' process modify alignment two loop
Graphics.Off=False ' reset color
Outpt="Player Alignment:" ' make message
Call IO.O ' display message
Outpt="Press "+Enter$+" for default." ' make message
Call IO.O ' display message
Graphics.Off=True ' reset color
For Align.Count=1 To 3 ' display alignment choices
Outpt=Mid$(Str$(Align.Count),2)+"> "+ _
Rtrim$(Alignment.Name2(Align.Count))
Call IO.O ' send output
Next ' loop through alignment chocies
Outpt="?" ' prompt for alignment number
No.Input.Out="2" ' default to neutral
Line.Length=1 ' reset line length
Call IO.I ' get input
Player.Alignment=Int(Val(Inpt)) ' convert to number
If Player.Alignment>=1 And Player.Alignment<=3 Then ' compare valid choice
Exit Do ' exit second loop
Endif ' end compare choice
Loop ' continue alignment loop
UserRecord.Align2=Player.Alignment-2 ' store alignment as -1/0/1
End Sub ' end routine to modify character alignment
Rem * routine to allow user to modify character class type.
Sub Modify.Class
On Local Error Resume Next ' local error resume
Outpt=Nul ' make empty line
Call IO.O ' send output
Do ' class entry process loop
Graphics.Off=False ' reset color
Call IO.O ' send blank line
Outpt="Select your character class:" ' make message
Call IO.O ' send output
Outpt="Press "+Enter$+" for default." ' make message
Call IO.O ' send output
If Local.Mode=False Then ' console mode allows DM/Asst. DM entries
Max.Class=8 ' set number of class choices
Else ' compare console mode
Max.Class=10 ' set number of class choices
Endif ' end compare console mode
Graphics.Off=True ' reset color
For List.Counter=1 To Max.Class ' loop through class chocies
Outpt=Mid$(Str$(List.Counter),2) ' store class number
If List.Counter=10 Then ' store DM class number
Outpt="#" ' choice ten is pound sign
Endif ' end compare DM class number
Outpt=Outpt+"> "+Rtrim$(Class.Name(List.Counter)) ' append class name
Call IO.O ' send output
Next ' loop through class choices
Outpt="?" ' set input prompt
No.Input.Out="1" ' set default choice
Line.Length=1 ' reset line length
Call IO.I ' get user input
Player.Class=Int(Val(Inpt)) ' convert to number
If Inpt="#" Then ' compare DM selection
Player.Class=10 ' set to ten
Endif ' end compare DM selection
If Player.Class>=1 And Player.Class<=Max.Class Then ' check class range
Exit Do ' exit class type entry loop
Endif ' end check class range
Loop ' end class type entry loop
UserRecord.ClassType=Player.Class ' store class number in user record
Outpt=Class.Name(UserRecord.ClassType) ' get class name
Call Valid(Outpt,20) ' validate class name
If Outpt=Nul Then ' verify class name validity
Outpt="<checksum>" ' set error message
Call Valid(Outpt,20) ' validate error
Endif ' end verify class name
Call Encrypt(Outpt,True) ' encrypt class name
UserRecord.ClassName=Outpt ' store class name in user record
End Sub ' end routine to modify character class type
Rem * routine to allow user to modify character statistics.
Sub Modify.Stats
On Local Error Resume Next ' local error resume
Do ' loop until statistics selected are accepted
Do ' loop until statistics are valid
Graphics.Off=False ' reset color
Outpt="Enter character statistics, range from 8 to 18." ' message
Call IO.O ' send message
Outpt="Average less than or equal to 12." ' message
Call IO.O ' send message
Outpt="Press "+Enter$+" for default." ' message
Call IO.O ' send message
Stat.Total!=False ' reset total of selected statistics
For Class.Number=1 To 7 ' loop through entry of all statistics
Do ' loop until a valid statistic entered
Graphics.Off=True ' reset color
Outpt=Rtrim$(Stat(Class.Number))+">" ' make message w/ stat name
No.Input.Out="12" ' set default
Line.Length=2 ' reset line length
Call IO.I ' get input
Stat=Int(Val(Inpt)) ' convert to number
If Stat<8 Or Stat>18 Then ' check range
Graphics.Off=False ' reset color
Outpt="The average statistic must range from 8 to 18."
Call IO.O ' send output message
Else ' check range
Stat.Total!=Stat.Total!+Stat ' increment stat total
UserRecord.Stats(Class.Number)=Stat ' store stat in user record
Exit Do ' exit validity loop
Endif ' end check range
Loop ' continue valid statistic loop
Next ' loop through all statistics
Stat.Total!=Stat.Total!/7! ' calculate average of total statistics
Stats$=Str$(Stat.Total!) ' convert to string
Stat.Delimit=Instr(Stats$,".") ' search string for decimal
If Stat.Delimit=False Then ' compare decimal
Inpt=Stats$ ' set output string to converted string
Else ' check decimal, truncate to one place
' set string
Inpt=Left$(Stats$,Stat.Delimit-1)+"."+Mid$(Stats$,Stat.Delimit+1,1)
Endif ' end compare decimal
Graphics.Off=False ' reset color
If Stat.Total!<=12 Then ' verify average
Exit Do ' exit validity loop
Endif ' end verify average
Outpt="Average"+Inpt+" to high! Try again.." ' set message
Call IO.O ' send message
Loop ' end statistic validity loop
Outpt="Your average is"+Inpt+". Change anything(y/n)? " ' make message
No.Input.Out="N" ' set default input
Line.Length=1 ' reset line length
Call IO.I ' get user input
If No Then ' check no entered
Exit Sub ' exit routine
Endif ' end check entry
Loop ' end loop to verify statistics accepted
End Sub ' end routine to modify character statistics
Rem * routine to allow user to modify character race.
Sub Modify.Race
On Local Error Resume Next ' local error resume
Do ' loop until race entry is accepted
Graphics.Off=False ' reset color
Outpt="Select your character race:" ' make message
Call IO.O ' send message
Outpt="Press "+Enter$+" for default." ' make message
Call IO.O ' send message
Graphics.Off=True ' reset color
For Race.Count=1 To 8 ' loop through all race choices
' choice display
Outpt=Mid$(Str$(Race.Count),2)+">"+Rtrim$(Race(Race.Count))
Call IO.O ' send choice
Next ' end race display loop
Outpt="?" ' set input prompt
No.Input.Out="1" ' set default
Line.Length=1 ' reset line length
Call IO.I ' get user input
Player.Race=Int(Val(Inpt)) ' convert to number
If Player.Race>=1 And Player.Race<=8 Then ' check race range
UserRecord.Race=Player.Race ' store race in user record
Exit Sub ' exit routine
Endif ' end compare race range
Loop ' end loop to accept race entry
End Sub ' end routine to modify race
Rem * routine to allow user to modify character weapon proficiency.
Sub Modify.Proficiency
On Local Error Resume Next ' local error resume
Do ' loop until proficiency entry accepted
Graphics.Off=False ' reset color
Outpt="Weapon Proficiency:" ' set message
Call IO.O ' send output
Outpt="Clerics may only use blunt or pole type weapons." ' message
Call IO.O ' send output
Outpt="Press "+Enter$+" for default." ' message
Call IO.O ' send output
Graphics.Off=True ' reset color
For Prof.Count=1 To 4 ' loop through all weapon proficiencies
Outpt=Mid$(Str$(Prof.Count),2)+"> "+ _
Rtrim$(Weapon.Type.Name(Prof.Count))
Call IO.O ' send choice output
Next ' end weapon choices
Outpt="?" ' set user prompt
If UserRecord.ClassType=Cleric Then ' compare class to cleric
No.Input.Out="1" ' set default
Else ' compare class
No.Input.Out="3" ' set default
Endif ' end compare class
Line.Length=1 ' reset line length
Call IO.I ' get user input
Player.Prof=Int(Val(Inpt)) ' convert to number
If UserRecord.ClassType=Cleric Then ' compare class to cleric
' compare valid choices for cleric
If Player.Prof=1 Or Player.Prof=2 Then
Exit Do ' exit weapon input loop
Endif ' end compare valid chocies
Else ' compare to non cleric
If Player.Prof>=1 And Player.Prof<=4 Then ' compare valid choices
Exit Do ' exit weapon input loop
Endif ' end compare valid choices
Endif ' end compare class type
Loop ' end loop to accept weapon proficiency
UserRecord.Proficiency=Player.Prof ' store character weapon selection
For Weapon.Number=1 To 4 ' loop through user record weapon proficiencies
UserRecord.Weapons(Weapon.Number)=False ' reset to zero
Next ' end loop through weapon proficiencies
' set user record selected weapon profciency
UserRecord.Weapons(Player.Prof)=10
End Sub ' end routine to modify character weapon proficinecy
Rem * routine to initialize character proficiency statistics.
Sub Init.Proficiency.Stats
On Local Error Resume Next ' local error resume
Graphics.Off=False ' reset color
Select Case UserRecord.Race ' compare player character race
Case 3 ' gnome race
UserRecord.Weapons(UserRecord.Proficiency)=15 ' increment proficiency
Outpt="Gnomes weapon proficiency is raised to 15%" ' make message
Call IO.O ' send message
Case 6 ' half-elf race
UserRecord.Weapons(4)=UserRecord.Weapons(4)+5 ' increment proficiency
Outpt="Half-elves thrusting weapon proficiency is raised by 5%" ' message
Call IO.O ' send message
Case 7 ' half-orc race
UserRecord.Weapons(3)=UserRecord.Weapons(3)+5 ' increment proficiency
Outpt="Half-orcs sharp weapon proficiency is raised by 5%" ' message
Call IO.O ' send message
End Select ' end compare race
End Sub ' end routine to initialize proficiency statistics
Rem * routine to initialize character race statistics.
Sub Init.Race.Stats
On Local Error Resume Next ' local error resume
Graphics.Off=False ' reset color
Select Case UserRecord.Race ' compare player character race
Case 1 ' human race
UserRecord.Stats(1)=UserRecord.Stats(1)+1 ' increment statistics
Outpt="Humans strength is raised one point!" ' make message
Call IO.O ' send message
Case 2 ' elf race
UserRecord.Stats(4)=UserRecord.Stats(4)+1 ' increment statistics
Outpt="Elves dexterity is raised by one point!" ' make message
Call IO.O ' send message
Case 4 ' dwarf race
UserRecord.Stats(2)=UserRecord.Stats(2)+1 ' increment statistics
Outpt="Dwarves intelligence is raised by one point!" ' make message
Call IO.O ' send message
Case 5 ' halfling race
UserRecord.Stats(3)=UserRecord.Stats(3)+1 ' increment statistics
Outpt="Halflings wisdom is raised by one point!" ' make message
Call IO.O ' send message
Case 8 ' ogre race
UserRecord.Stats(1)=UserRecord.Stats(1)+1 ' increment statistics
UserRecord.Stats(4)=UserRecord.Stats(4)+1 ' increment statistics
Outpt="Ogres strength and dexterity are raised by one point!" ' message
Call IO.O ' send output
End Select ' end compare race
UserRecord.Beauty=Int(Rnd*15+5) ' reset ladies beauty
UserRecord.Glamour=Int(Rnd*15+5) ' reset ladies glamour
End Sub ' end routine to initialize character race statistics
Rem * routine to initialize some character statistics.
Sub Init.Stats
On Local Error Resume Next ' local error resume
User.Echo=False ' reset preference
User.LineFeeds=False ' reset preference
User.LineLength=80 ' reset preference
User.PageLength=24 ' reset preference
User.Wordwrap=False ' reset preference
UserRecord.Room=1 ' reset user record room number
UserRecord.Level=1 ' reset user record character level
UserRecord.Experience=64 ' reset experience
UserRecord.Gold=2048 ' reset user record gold
UserRecord.Bank=False ' reset user record amount of gold in bank
UserRecord.Borrow=False ' reset user record amount of gold borrowed from bank
UserRecord.Brief=False ' reset user record brief mode
UserRecord.Echo=False ' reset user echo mode
UserRecord.Linefeeds=False ' reset user linefeed mode
UserRecord.Linelength=80 ' reset user linelength
UserRecord.Pagelength=24 ' reset pagelength
UserRecord.Wordwrap=False ' reset user word wrap
UserRecord.FatigueMax=Training.Stats(UserRecord.ClassType,1) ' reset user
UserRecord.VitalityMax=Training.Stats(UserRecord.ClassType,2) ' record maximum
UserRecord.MagicMax=Training.Stats(UserRecord.ClassType,3) ' statistic
UserRecord.PsionicMax=Training.Stats(UserRecord.ClassType,4) ' points
UserRecord.Fatigue=UserRecord.FatigueMax ' reset user
UserRecord.Vitality=UserRecord.VitalityMax ' record working
UserRecord.Magic=UserRecord.MagicMax ' statistic
UserRecord.Psionic=UserRecord.PsionicMax ' points
UserRecord.MaxCalls=False ' reset user record maximum calls
UserRecord.FromHour=False ' reset user record time restrictions
UserRecord.FromMin=False ' reset user record time restrictions
UserRecord.ToHour=False ' reset user record time restrictions
UserRecord.ToMin=False ' reset user record time restrictions
UserRecord.Flags=False ' reset user record flags variable
Call Clear.Container(0,True) ' routine to clear the container structure
For Container.Item=1 To 3 ' loop through user record containers
UserRecord.Container(Container.Item)=ContainerRec ' reset container record
Next ' end loop through user record
End Sub ' end routine to initialize character statistics
Rem * routine to display login character statistics.
Sub Display.Init.Stats
On Local Error Resume Next ' local error resume
Graphics.Off=False ' reset color
Outpt="Your character statistics are:" ' message
Call IO.O ' send output
Graphics.Off=True ' reset color
Outpt="Level:"+Str$(UserRecord.Level) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Alignment.Type$=Alignment.Name1(UserRecord.Align1+2) ' message
Alignment.Type$=Rtrim$(Alignment.Type$) ' trim blanks
' first character uppercase
Mid$(Alignment.Type$,1,1)=Ucase$(Mid$(Alignment.Type$,1,1))
Outpt=Outpt+"Align1: "+Alignment.Type$ ' combine message
Call IO.O ' send output
Outpt="Gold: "+Str$(UserRecord.Gold) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Alignment.Type$=Alignment.Name2(UserRecord.Align2+2) ' message
Alignment.Type$=Rtrim$(Alignment.Type$) ' trim blanks
' first character uppercase
Mid$(Alignment.Type$,1,1)=Ucase$(Mid$(Alignment.Type$,1,1))
Outpt=Outpt+"Align2: "+Alignment.Type$ ' combine message
Call IO.O ' send output
Outpt="Room: "+Str$(UserRecord.Room) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Player.Prof=UserRecord.Proficiency ' get statistic
Weapon.Type$=Weapon.Type.Name(Player.Prof) ' message
Weapon.Type$=Rtrim$(Weapon.Type$) ' trim blanks
' first character uppercase
Mid$(Weapon.Type$,1,1)=Ucase$(Mid$(Weapon.Type$,1,1))
Outpt=Outpt+"Prof: "+Weapon.Type$ ' combine message
Weapon.Proficiency$=Str$(UserRecord.Weapons(Player.Prof)) ' message
Outpt=Outpt+">"+Weapon.Proficiency$+"%" ' combine message
Call IO.O ' send output
Outpt="Exp: "+Str$(UserRecord.Experience) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(1),3)+": "+Str$(UserRecord.Stats(1)) ' combine
Call IO.O ' send output
Outpt="Fat: "+Str$(UserRecord.Fatigue) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(2),3)+": "+Str$(UserRecord.Stats(2)) ' combine
Call IO.O ' send output
Outpt="Vit: "+Str$(UserRecord.Vitality) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(3),3)+": "+Str$(UserRecord.Stats(3)) ' combine
Call IO.O ' send output
Outpt="Mag: "+Str$(UserRecord.Magic) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(4),3)+": "+Str$(UserRecord.Stats(4)) ' combine
Call IO.O ' send output
Outpt="Psi: "+Str$(UserRecord.Psionic) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(5),3)+": "+Str$(UserRecord.Stats(5)) ' combine
Call IO.O ' send output
Outpt="Race: "+Race(UserRecord.Race) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(6),3)+": "+Str$(UserRecord.Stats(6)) ' combine
Call IO.O ' send output
Class.Type$=UserRecord.ClassName ' message
Call Decrypt(Class.Type$) ' decrypt string
' first character uppercase
Mid$(Class.Type$,1,1)=Ucase$(Mid$(Class.Type$,1,1))
Class.Type$=Left$(Class.Type$,15) ' truncate to right
Outpt="Class: "+Class.Type$ ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+Left$(Stat(7),3)+": "+Str$(UserRecord.Stats(7)) ' combine
Call IO.O ' send output
If UserRecord.ClassType=Lady Then ' compare class to lady
Outpt="Lady stats:" ' message
Call IO.O ' send output
Outpt="Beauty:"+Str$(UserRecord.Beauty) ' message
Outpt=Outpt+Space$(25-Len(Outpt)) ' append blanks
Outpt=Outpt+"Glamour:"+Str$(UserRecord.Glamour) ' combine
Call IO.O ' send output
Endif ' end compare class type
Call More.Prompt ' pause to continue
End Sub ' end routine to display character login statistics
Rem * routine to initialize some variables after login.
Rem * output variables:
Rem * Time.Left - player time left in seconds from login time.
Sub Update.Login
On Local Error Resume Next ' local error resume
Outpt=UserRecord.DateOn ' get user's last login date
Call Decrypt(Outpt) ' decrypt date
If Outpt<>Date$ Then ' compare last login date to today
UserRecord.NumCalls=False ' reset user's number of calls logged in per day
Endif ' end compare last login date
If UserRecord.ClassType<=Lady Then ' compare user to non DM status
Calls.Exceeded=False ' set flag to maximum calls exceeded
UserRecord.NumCalls=UserRecord.NumCalls+1 ' increment user's max calls
If UserRecord.MaxCalls>False Then ' compare maximum calls
If UserRecord.NumCalls>UserRecord.MaxCalls Then ' compare calls
Calls.Exceeded=True ' set maximum call flag
Endif ' end compare calls to maximum calls
Else ' end compare maximum calls
If UserRecord.NumCalls>5 Then ' compare maximum calls to default
Calls.Exceeded=True ' set maximum call flag
Endif ' end compare maximum default calls
Endif ' end compare maximum calls
If Calls.Exceeded Then ' check user has exceeded maximum calls
Call Share.Record(UserFile,User.Index) ' put user record
Call Hang.Up(5) ' routine to terminate program w/ message
Exit Sub ' exit routine
Endif ' end check maximum calls
Endif ' end non DM status
Call Restricted.Login ' check user is restricted to a time to login
If UserRecord.ClassType<AsstDM Then ' compare user is non DM status
UserRecord.Invisible=False ' reset user invisibility
Endif ' end compare non DM status
Select Case UserRecord.ClassType ' compare the user class type
Case Is>=AsstDM ' user is DM/Asst. DM
Time.Left=3600! ' user gets 60 minutes
Case Else ' user is non DM
Select Case UserRecord.Level ' select by user level
Case Is<2 ' user level is less than two
Time.Left=900! ' user gets 15 mminutes
Case Else ' user level is two or more
Time.Left=1800! ' user gets 30 minutes
End Select ' end user level
End Select ' end user DM status
If Time.Left>Door.Time Then ' compare user's time left to door file time left
If Door.Time>False Then ' compare door file time
Time.Left=Door.Time ' reset time left to door time left
Endif ' end compare door file time
Endif ' end compare user time left
Two.Minutes.Left=False ' reset two minutes left message flag
User.Echo=UserRecord.Echo ' store user preference
User.LineFeeds=UserRecord.LineFeeds ' store user preference
User.LineLength=UserRecord.LineLength ' store user preference
User.PageLength=UserRecord.PageLength ' store user preference
User.Wordwrap=UserRecord.Wordwrap ' store user preference
End Sub ' end routine to initialize some login variables
Rem * routine to check user is restricted to specific login times.
Rem * work variables:
Rem * Restrict.Start! - time in seconds to restrict logon.
Rem * Restrict.End! - time in seconds to restrict logon.
Sub Restricted.Login
On Local Error Resume Next ' local error resume
' calculate time restrictions
Restrict.Start!=Csng(UserRecord.FromHour*3600!+UserRecord.FromMin*60!)
Restrict.End!=Csng(UserRecord.ToHour*3600!+UserRecord.ToMin*60!)
' compare any time restriction
If Restrict.Start!>False Or Restrict.End!>False Then
If Timer<Restrict.Start! Or Timer>Restrict.End! Then ' compare time to now
Call Hang.Up(6) ' routine to terminate program w/ message
Endif ' end compare time
Endif ' end compare time restriction
End Sub ' end routine to check restricted time login
Rem * routine to intialize some new user variables in user file record.
Sub Init.Newuser
On Local Error Resume Next ' local error resume
UserRecord.NumCalls=False ' reset maximum calls made today
UserRecord.ClassType=False ' reset class type
Outpt=Player.CodeName ' store codename
Call Valid(Outpt,30) ' validate codename
Call Encrypt(Outpt,True) ' encrypt codename
UserRecord.CodeName=Outpt ' restore codename
Outpt=Player.PassWord ' store password
Call Valid(Outpt,20) ' validate password
Call Encrypt(Outpt,False) ' encrypt password
UserRecord.PassWord=Outpt ' restore password
Outpt=Deleted$ ' set deleted
Call Valid(Outpt,20) ' validate deleted
Call Encrypt(Outpt,True) ' encrypt deleted
UserRecord.ClassName=Outpt ' reset classname
Outpt=Date$ ' store current date
Call Valid(Outpt,10) ' validate date
Call Encrypt(Outpt,True) ' encrypt date
UserRecord.DateOn=Outpt ' reset date
UserRecord.MaxCalls=False ' reset maximum calls made
UserRecord.FromHour=False ' reset time restrictions
UserRecord.FromMin=False
UserRecord.ToHour=False
UserRecord.ToMin=False
End Sub ' end routine to intialize new user variables
Rem * routine to initialize some user variables.
Sub Login.User
On Local Error Resume Next ' local error resume
Number.Monsters=False ' counter of monsters currently in the room
Monsters.Killed=False ' counter of monster killed by player during session
' allocate room monster arrays
Redim MonsterArray(1 To 20) As MonsterType, _
MonsterIndex(1 To 20) As Integer
Max.Spells=Lof(SpellFile)/Len(SpellRecord) ' compute number of spells in file
If Max.Spells=False Then ' compare empty file
Max.Spells=1 ' set number to at least one
Call Share.Record(SpellFile,1) ' put default spell record
Endif ' end compare file
' check bounds of spell file
If Max.Spells>1024 Then ' check bounds
Max.Spells=1024 ' reste maximum
Endif ' end check bounds
' make string of zeros length of spell file
Learned.Spells=String$(Max.Spells,"0")
If UserRecord.Race<=False Then ' check user race
UserRecord.Race=1 ' reset to one
Endif ' end check race
Call Share.Record(UserFile,User.Index) ' put the user record
Room=UserRecord.Room ' store the room number
If UserRecord.Level=False Then ' check user level
Outpt="You are level zero. You can use the train command once free."
Call IO.O ' send output message
Endif ' end compare level
Call Bank.Interest ' calculate bank interest for balance and loan
Call Check.Mail ' routine to display number of new messages to player
Weapon1=False ' reset working game weapon, shield, armor, and ring variables
Weapon2=False ' reset variable
Weapon3=False ' reset variable
Weapon4=False ' reset variable
Weapon5=False ' reset variable
Weapon6=False ' reset variable
Weapon7=False ' reset variable
Weapon8=False ' reset variable
Weapon9=False ' reset variable
Weapon10=False ' reset variable
Call Get.User.Record ' read the user record
Call Status.Line(1) ' initialize the console status lines
Func.Buffer=Nul ' reset function key buffer
End Sub ' end routine to initialize some user variables
Rem * routine to display treasure item.
Rem * input variables:
Rem * Index.Number - treasure record number.
Rem * Type.Number - room/inventory flag.
Sub Show.Treasure
On Local Error Resume Next ' local error resume
If Type.Number Then ' compare treasure in room
Prefix1="It's " ' format prefix
Else ' compare treasure in player inventory
Prefix1="You are carrying " ' format prefix
Endif ' end compare treasure
Graphics.Off=True ' reset color
If TreasureRecord.Scroll Then ' compare treasure to scroll
If TreasureRecord.Spell Then ' check scroll spell number
Call Read.Record(SpellFile,TreasureRecord.Spell) ' get spell record
Inpt=SpellRecord.Chant ' store spell chant
Inpt=Rtrim$(Inpt) ' trim chant
Inpt=Lcase$(Inpt) ' trim chant
Outpt="It reads: '"+Inpt+"'." ' display scroll chant
Call IO.O ' send message
Outpt="It disintegrated!" ' scroll vanished message
Call IO.O ' send output
If Type.Number=False Then ' compare treasure in room
' remove scroll from inventory
Call Discard.Inventory(Array.Number,True)
Else ' compare treasure
Call Discard.Room.Treasure(Array.Number) ' remove scroll from room
Endif ' end compare treasure
Endif ' end compare scroll spell number
Exit Sub ' exit routine
Endif ' end compare treasure is scroll
Outpt=Prefix1+Outpts ' format treasure name description
If TreasureRecord.Keyed Then ' append key number to treasure name
Outpt=Outpt+"(#"+Right$(Str$(TreasureRecord.Keyed+100000!),5)+")"
Endif ' end compare treasure key number
If TreasureRecord.Plus Then ' append plus number to treasure name
Outpt=Outpt+"(+"+Mid$(Str$(Abs(TreasureRecord.Plus)),2)+")"
Endif ' end compare treasure plus
If TreasureRecord.Spell Then ' append spell plus to treasure name
Call Read.Record(SpellFile,TreasureRecord.Spell) ' get spell record
Outpt=Outpt+"(+"+Mid$(Str$(SpellRecord.Level),2)+")"
Endif ' end compare treasure spell plus
If TreasureRecord.LightType Then ' compare treasure to a light
If Charges.Number<False Then ' check treasure is also lit
Outpt=Outpt+"[lit]" ' append to treasure name
Endif ' end check lit treasure
Endif ' end compare treasure to light
If TreasureRecord.Invisible Then ' compare treasure is invisible
Outpt=Outpt+"[inv]" ' append to treasure name
Else ' compare treasure
If Type.Number=1 Then ' check treasure is in room
' verify treasure in
If RoomRecord.Flags(Array.Number)=Hidden.Object Then
Outpt=Outpt+"[inv]" ' room is invisible, append to name
Endif ' end verify treasure in room was hidden
Endif ' end check treasure in room
Endif ' end compare treasure is invisible
Call IO.O ' display treasure name message
If TreasureRecord.Proficiency Then ' compare treasure proficiency
Outpt=Weapon.Type.Name(TreasureRecord.Proficiency) ' get proficiency
Outpt=Rtrim$(Outpt) ' name and trim
Outpt="This is a "+Outpt+" weapon." ' make weapon type message
Call IO.O ' display weapon type message
Endif ' end compare treasure proficiency
If Last.Command.Number=Identify.Command Then ' check identify command used
Outpt="It's worth"+Str$(TreasureRecord.Gold)+" gold peices."
Call IO.O ' display treasure item gold value
Outpt="It weighs"+Str$(TreasureRecord.Weight)+" pounds."
Call IO.O ' display weight of item
If TreasureRecord.RingType Then ' compare treasure ring type
Select Case TreasureRecord.RingType ' determine ring type
Case 1 ' ring type
Outpt="protection from poison." ' ring type message
Case 2 ' ring type
Outpt="protection from level drain." ' ring type message
Case 3 ' ring type
Outpt="protection from spells." ' ring type message
End Select ' end dtermine ring type
Outpt="Its ring spell is "+Outpt ' make ring type message
Call IO.O ' send ring type message
Endif ' end compare treasure to ring
If TreasureRecord.Spell Then ' compare treasure spell type
Call Read.Record(SpellFile,TreasureRecord.Spell) ' get treasure spell
Outpt="Its magical spell is "+Rtrim$(SpellRecord.SpellName)+"."
Call IO.O ' display name of treasure spell
Endif ' end compare treasure spell type
' compare treasure is loaded
If TreasureRecord.Loadable Or TreasureRecord.Launchable Then
If Charges.Number<=False Then ' compare treasure charges
Outpt="It's not loaded." ' display message
Else ' compare treasure charges
Outpt="It's loaded with"+Str$(Charges.Number)+" charges." ' message
Endif ' end compare loaded treasure charges
Call IO.O ' send message of charges in loaded treasure
Else ' compare treasure item
If TreasureRecord.LightType Then ' compare treasure is a light
If Charges.Number<False Then ' compare light charges (is negative)
Outpt="It's fueled with"+Str$(Abs(Charges.Number))+" charges."
Call IO.O ' send message of charges in light
Endif ' end compare light charges
Else ' compare other treasure plus
If TreasureRecord.RingType Or TreasureRecord.Spell Or _
TreasureRecord.Plus Then ' treasure has charges
If Charges.Number<=False Then ' compare charges
Outpt="It's empty of charges." ' message
Else ' compare charges
' message of charges
Outpt="It has"+Str$(Charges.Number)+" charges."
Endif ' end compare charges
Call IO.O ' send message of charges
Endif ' end compare treasure charges
Endif ' end compare treasure plus
Endif ' end compare treasure
' compare treasure is ammunition
If TreasureRecord.Ammunition Or TreasureRecord.LaunchAmmo Then
Outpt="It's ammunition." ' treasure nessage
Call IO.O ' send message
Endif ' end compare treasure
If TreasureRecord.Potion Then ' compare treasure to potion
Outpt="It's a potion." ' make message
Call IO.O ' send message
Endif ' end compare to potion
If TreasureRecord.Edible Then ' compare treasure to food
Outpt="It's edible." ' make message
Call IO.O ' send message
Endif ' end compare to food
Endif ' end identify command
Graphics.Off=False ' reset color
End Sub ' end routine to display an itemof treasure
Rem * routine to display object information.
Rem * input variables:
Rem * Index.Number - object record number.
Rem * Type.Number - object is in room/inventory.
Sub Show.Object
On Local Error Resume Next ' local error resume
If Type.Number Then ' determine object in room
Prefix1="It's " ' make prefix
Else ' object in inventory
Prefix1="You are carrying " ' make prefix
Endif ' end determine in room
Graphics.Off=True ' reset color
Outpt=Prefix1+Outpts ' make message with object name
If ObjectRecord.DoorLock>1 Then ' compare object is locked
Outpt=Outpt+"[locked]" ' append to object name
Endif ' end compare locked object
If ObjectRecord.DoorLock=1 Then ' compare object is unlocked
If ObjectRecord.Closed Then ' compare object is closed
Outpt=Outpt+"[closed]" ' append to object name
Endif ' end compare closed object
Endif ' end compare object lock
If ObjectRecord.Invisible Then ' compare object is invisible
Outpt=Outpt+"[inv]" ' append to object name
Endif ' end compare object invisible
If ObjectRecord.Keyed Then ' compare object key, append number to name
Outpt=Outpt+"(#"+Right$(Str$(ObjectRecord.Keyed+100000!),5)+")"
Endif ' end compare object key number
Call IO.O ' display message with object name
Outpt=ObjectRecord.LongDesc ' store object additional description
Outpt=Rtrim$(Outpt) ' trim description
If Outpt<>Nul Then ' compare length of description
Call IO.O ' display additional object description
Endif ' end compare object description length
Graphics.Off=False ' reset color
End Sub ' end routine to display object information
Rem * routine to display information on a monster.
Rem * input variables:
Rem * Monster.Number - number of monster array.
Sub Show.Monster
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Call The.Or.An ' routine for monster name prefix (a, an, the)
Level=MonsterArray(Monster.Number).Level ' store monster level
Outpt="It's "+Prefix1+Outpts ' make message of monster name
' append monster level (range of player's level capable to kill monster)
Outpt=Outpt+"(level"+Str$((Level-1)*2+1)+" to"+Str$(Level*2)+")"
Call IO.O ' send message with monster name and level range
If Last.Command.Number=Identify.Command Then ' compare identify command
Gold.Points#=MonsterArray(Monster.Number).Gold ' store monster gold
If Gold.Points#<=False Then ' compare monster gold
Gold.Points#=10 ' set to minimum
Endif ' end compare monster gold
Outpt="It has"+Str$(MonsterArray(Monster.Number).Hits)+" hits,"+ _
Str$(MonsterArray(Monster.Number).Experience)+" experience, and"+ _
Str$(Gold.Points#)+" gold."
Call IO.O ' display message of monster gold
Outpt="It carries the following treasure:" ' make message
Call IO.O ' send message of treasure carried by monster
Inventory.Count=False ' reset number of monster inventory items displayed
For Array.Count=1 To 5 ' loop through all monster inventory
' get treasure
Treasure.Number=MonsterArray(Monster.Number).Treasure(Array.Count)
' number and check range in treasure file
If Treasure.Number>False And _
Treasure.Number<=Lof(TreasureFile)/Len(TreasureRecord) Then
Carriage.Return=True ' flag to disable return/linefeed
Call IO.O ' send output of previous item
Call Read.Record(TreasureFile,Treasure.Number) 'get treasure record
Outpts=TreasureRecord.TreasureName ' store treasure name
Outpt=Rtrim$(Outpts)+", " ' trim name, append comma
Inventory.Count=Inventory.Count+1 ' increment items displayed flag
If Inventory.Count=1 Then ' compare item to first displayed
Mid$(Outpt,1,1)=Ucase$(Mid$(Outpt,1,1)) ' uppercase first item
Endif ' end compare first item
Endif ' end check treasure file range
Next ' end loop through monster inventory
If Inventory.Count=False Then ' check if any items displayed
Outpt="Nothing at all." ' make message for none
Else ' check items displayed
Outpt=Left$(Outpt,Len(Outpt)-2)+"." ' trim comma, append period
If Inventory.Count>1 Then ' check more than one item displayed
Outpt="and "+Outpt ' append to last item
Endif ' end check items
Endif ' end check item
Call IO.O ' send output for last item
' compare monster spell ability
Spell.Number=MonsterArray(Monster.Number).Spell
' check spell
If Spell.Number>False And _
Spell.Number<=Lof(SpellFile)/Len(SpellRecord) Then
Call Read.Record(SpellFile,Spell.Number) ' range and get spell record
Outpt="It can cast "+Rtrim$(SpellRecord.SpellName)+" spells!"
Call IO.O ' send message of spell name monster can cast
Endif ' end compare monster spell
If MonsterArray(Monster.Number).Poison Then ' compare monster poisonous
Outpt="It can poison!" ' make message
Call IO.O ' send output message
Endif ' end compare monster poisonous
If MonsterArray(Monster.Number).LevelDrain Then ' compare monster undead
Outpt="It can drain levels!" ' make message
Call IO.O ' send output message
Endif ' end compare monster undead
If MonsterArray(Monster.Number).Psionic Then ' compare monster astral
Outpt="It can cast psi spells!" ' make message
Call IO.O ' send output message
Endif ' end compare monster astral
Endif ' end check identify command used
Graphics.Off=False ' reset color
End Sub ' end routine to display monster information
Rem * routine to determine validity of room number.
Rem * input variables:
Rem * Room - contains room number to check.
Sub Check.Next.Room
On Local Error Resume Next ' local error resume
Do ' loop until room is valid, room is created, or nondescriptive hangup
If Room>False And _
Room<=Lof(RoomFile)/Len(RoomRecord) Then ' check room range
Call Read.Room.Record(Room) ' valid range, get room record
Exit Sub ' exit routine
Endif ' end check valid range
If Room>Lof(RoomFile)/Len(RoomRecord) Then ' compare room number range
If Not Normal.User Then ' check non DM status
Call Add.Room(False,Room.Created) ' routine to create new room
If Room.Created Then ' return variable indicates new room created
Exit Sub ' exit routine
Endif ' end create new room
Endif ' end check normal user
Endif ' end compare room number range
' otherwise, any room number out of range will be changed to room 1, or
' changed to the resurrection room number.
If Lof(RoomFile)/Len(RoomRecord)>=1 Then ' check for room
Graphics.Off=False ' reset color
Outpt="Nondescriptive room number"+Str$(Room)+"!" ' make error message
Call IO.O ' display room number error message
Room=1 ' reset room number to resurrection room, continue loop
Else ' room file is invalid, room file length is zero
Graphics.Off=False ' reset color
Room=1 ' reset room number
Call Clear.Room(1) ' add first room
Exit Sub ' exit routine
Endif ' end check room file length
Loop ' end loop until valid room number
End Sub ' end routine to check room number validity
Rem * routine to initialize some room variables, check next room number, and
Rem * display next room description.
Rem * input variables:
Rem * Room - room number to move to.
Rem * output variables:
Rem * Room.Rust.Rate - number of prompts to check weapon rusting.
Rem * Room.Steal.Rate - number of prompts to check monster stealing.
Rem * Room.Monster.Rate - number of prompts to check monster encounter.
Rem * Room.Health.Rate - number of prompts to check health increases.
Sub Display.Room
On Local Error Resume Next ' local error resume
Call Check.Next.Room ' routine to verify next room number
Room.Rust.Rate=False ' store room rust rate
Room.Steal.Rate=False ' store room steal rate
Room.Monster.Rate=6 ' store default room encounter rate
Room.Health.Rate=6 ' store default room health rate
Room.Action=RoomRecord.Action
If Room.Action>False And Room.Action<=Lof(ActionFile)/Len(ActionRecord) Then
Call Read.Record(ActionFile,Room.Action)
If ActionRecord.RustRate>False Then ' check room record action rust rate
Room.Rust.Rate=ActionRecord.RustRate ' store room rust rate
Endif ' end check action
If ActionRecord.StealRate>False Then ' check room record action steal rate
Room.Steal.Rate=ActionRecord.StealRate ' store room steal rate
Endif ' end check action
' check room record action encounter rate
If ActionRecord.EncounterRate Then
' store action encounter rate
Room.Monster.Rate=ActionRecord.EncounterRate
Endif ' end check action
If ActionRecord.HealthRate Then ' check room record action health rate
Room.Health.Rate=ActionRecord.HealthRate ' store action health rate
Endif ' end check action
Endif
Call Show.Room ' routine to display room
End Sub ' end routine to process next room
Rem * routine to determine if a room is unlit.
Rem * return variables:
Rem * Lit.Room - true if room is unlit.
Sub Check.Lit.Room(Lit.Room)
On Local Error Resume Next ' local error resume
Lit.Room=False ' room is lit by default
Call Read.Room.Record(Room) ' get room record
Action.Number=RoomRecord.Action ' store action number
' check action number
If Action.Number<1 Or Action.Number>Lof(ActionFile)/Len(ActionRecord) Then
Lit.Room=False ' room is lit
Exit Sub ' exit lit check routine
Endif ' end check action number
Call Read.Record(ActionFile,Action.Number) ' get action record number
If ActionRecord.Attribute1=LitRoom Then ' compare lit flag
Lit.Room=False ' room is lit
Exit Sub ' exit check lit routine
Endif ' end check lit flag
Lit.Room=True ' flag for unlit room
For Array.Index=1 To 20 ' loop through all user inventory
Treasure.Number=UserRecord.Inv(Array.Index) ' get inventory number
If Treasure.Number Then ' compare user treasure number
Call Read.Record(TreasureFile,Treasure.Number) ' get treasure record
If TreasureRecord.LightType Then ' check treasure item is a light
' check light is charged/lit
If UserRecord.Charges(Array.Index)<False Then
Lit.Room=False ' set flag for lit room
Exit Sub ' exit routine
Endif ' end check charged light
Endif ' end check treasure is a light
Endif ' end compare treasure number
Next ' end loop through user inventory
For Array.Index=1 To 20 ' loop through all treasure in room
' get room treasure number
Treasure.Number=RoomRecord.Treasure(Array.Index)
If Treasure.Number Then ' compare treasure number
Call Read.Record(TreasureFile,Treasure.Number) ' get treasure record
If TreasureRecord.LightType Then ' compare treasure is a light
' compare light is charged
If RoomRecord.TreCharges(Array.Index)<False Then
Lit.Room=False ' set flag for lit room
Exit Sub ' exit routine
Endif ' end compare charged light
Endif ' end compare treasure is a light
Endif ' end compare treasure number
Next ' end loop through room treasure
For Array.Index=1 To 20 ' loop through all room objects
If RoomRecord.Object(Array.Index) Then ' compare room object number
Call Read.Record(ObjectFile,RoomRecord.Object(Array.Index)) 'get record
If ObjectRecord.LightRoom Then ' check object is a light
If ObjectRecord.LightTime=False Then ' object lights at any time
Lit.Room=False ' set flag for lit room
Exit Sub ' exit routine
Else ' light has light time restriction
' calculate seconds light from/to
Start.Time!=Csng(ObjectRecord.FromHour*3600!+ _
ObjectRecord.FromMin*60!)
End.Time!=Csng(ObjectRecord.ToHour*3600!+ObjectRecord.ToMin*60!)
' check valid light time
If Start.Time!>False Or End.Time!>False Then
' compare times
If Timer>=Start.Time! And Timer<=End.Time! Then
Lit.Room=False ' set room lit flag
Exit Sub ' exit routine
Endif ' end compare times
Endif ' end check valid light time
Endif ' end check object light type
Endif ' end check object is a light
Endif ' end compare object number
Next ' end loop through room objects
For Array.Index=1 To 5 ' loop through all user object inventory
If UserRecord.Object(Array.Index) Then ' compare user object number
Call Read.Record(ObjectFile,UserRecord.Object(Array.Index)) 'get object
If ObjectRecord.LightRoom Then ' compare object is a light
If ObjectRecord.LightTime=False Then ' check object lights any time
Lit.Room=False ' set flag for lit room
Exit Sub ' exit routine
Else ' compare object light time restriction
' calculate seconds light from/to
Start.Time!=Csng(ObjectRecord.FromHour*3600!+ _
ObjectRecord.FromMin*60!)
End.Time!=Csng(ObjectRecord.ToHour*3600!+ObjectRecord.ToMin*60!)
' check valid light time
If Start.Time!>False Or End.Time!>False Then
' compare times
If Timer>=Start.Time! And Timer<=End.Time! Then
Lit.Room=False ' set lit room flag
Exit Sub ' exit routine
Endif ' end compare times
Endif ' end check valid light times
Endif ' end compare object light type
Endif ' end compare object is a light
Endif ' end compare object number
Next ' end loop through user objects
End Sub ' end routine to determine lit room
Rem * routine to display all the player character statistics.
Sub Display.Stats
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Outpt=UserRecord.CodeName ' get user codename
Call Decrypt(Outpt) ' decrypt codename
Outpt=Rtrim$(Outpt) ' trim codename
Outpt=Lcase$(Outpt) ' set codename to lowercase
Mid$(Outpt,1,1)=Ucase$(Mid$(Outpt,1,1)) ' uppercase first letter
Outpt="Information: "+Outpt+". "+FNclock$+"." ' make information message
Call IO.O ' send message
Call Show.Align ' routine to display player alignment
Call More.Prompt ' pause display
If No Then ' check more prompt response
Exit Sub ' exit info display
Endif ' end check more prompt
Call Show.Health ' routine to display player statistics
Call More.Prompt ' pause display
If No Then ' check more prompt response
Exit Sub ' exit info display
Endif ' end check more prompt
Call Display.Info ' routine to display additional player information
Call More.Prompt ' pause display
If No Then ' check more prompt response
Exit Sub ' exit info display
Endif ' end check more prompt
Call Display.Inventory ' routine to display player inventory
Call More.Prompt ' pause display
If No Then ' check more prompt response
Exit Sub ' exit info display
Endif ' end check more prompt
Call Display.Experience ' routine to display player experience and gold
Call More.Prompt ' pause display
If No Then ' check more prompt response
Exit Sub ' exit info display
Endif ' end check more prompt
End Sub ' end routine to display all player character statistics
Rem * routine to display player character experience, and gold.
Rem * routine notes:
Rem * although gold and experience required to reach the next level double
Rem * each player level, the experience and gold required for players over
Rem * level 10 only increase by 10,000 points per level over 10.
Sub Display.Experience
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Outpt="You have "+FNform$(UserRecord.Gold)+" gold and "+ _
FNform$(UserRecord.Experience)+" experience." ' make gold/experience message
Call IO.O ' send output message
Level=UserRecord.Level ' store player level
If Level>False And Level<MaxInt Then ' compare level maximum
Level=Level+1 ' increment next level needed
' routine to calculate gold required for next level
Call Gold(Gold.Required#)
Call Experience(Exp.Required#) ' routine to calculate experience needed
Outpt="You need "+FNform$(Gold.Required#)+" gold and "+ _
FNform$(Exp.Required#)+" experience to reach level"+Str$(Level)+"."
Call IO.O ' send output message
Else ' compare level
Outpt="There is no experience or gold at your level."
Call IO.O
Endif ' end compare level
End Sub
Rem * routine to display player characteristics, and weapons, shields, armor,
Rem * and rings being held/worn.
Sub Display.Info
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
If Sysop Then ' verify user is a sysop
Outpt="You are a Sysop!" ' make message
Call IO.O ' send message
Endif ' end verify sysop
If Dungeon.Master Then ' verify user is a DM
Outpt="You are a Dungeon Master!" ' make message
Call IO.O ' send message
Endif ' end verify DM
If Dungeon.Master.Assistant Then ' verify user is an Asst. DM
Outpt="You are an Assistant Dungeon Master!" ' make message
Call IO.O ' send message
Endif ' end verify Asst. DM
If Town.Mayor Then ' verify user is the mayor
Outpt="You are the Town Mayor!" ' make message
Call IO.O ' send message
Endif ' end verify mayor
If Governor Then ' verify user is governor
Outpt="You are the Governor!" ' make message
Call IO.O ' send message
Endif ' end verify governor
If Guild.Master Then ' verify user is guild master
Outpt="You are the Guild Master!" ' make message
Call IO.O ' send message
Endif ' end verify guild master
If UserRecord.Invisible Or Invisible Then ' check invisibility
Outpt="You are invisible!" ' make message
Call IO.O ' send message
Endif ' end check invisibility
If UserRecord.Poison Then ' check poisoned
Outpt="You are poisoned!" ' make message
Call IO.O ' send message
Endif ' end check poisoned
If Weapon1=False Then ' check wearing armor
If Weapon7=False Then ' check wearing ring
Outpt="You are wearing nothing." ' make message
Call IO.O ' send message
Endif ' end check ring
Endif ' end check armor
If Weapon2=False Then ' check holding weapon
If Weapon3=False Then ' check holding shield
Outpt="You are holding nothing." ' make message
Call IO.O ' send message
Endif ' end check shield
Endif ' end check weapon
Outpt=Nul ' clear display string
If Weapon1 Or Weapon7 Then ' check either armor or ring being worn
Outpt="You are wearing " ' initialize display string
If Weapon1 Then ' check armor being worn
Call Read.Record(TreasureFile,Abs(UserRecord.Inv(Weapon4))) ' get armor
Outpt=Outpt+Rtrim$(TreasureRecord.TreasureName) ' record, append name
Endif ' end check armor worn
Endif ' end check either being worn
If Weapon7 Then ' check ring being worn
Call Read.Record(TreasureFile,Abs(UserRecord.Inv(Weapon7))) 'ring treasure
If Weapon1 Then ' check armor worn again
Outpt=Outpt+" and "+Rtrim$(TreasureRecord.TreasureName)+"." ' append
Call IO.O ' both items being worn
Else ' armor not worn
Outpt="You are wearing "+Rtrim$(TreasureRecord.TreasureName)+"."
Call IO.O ' display only ring being worn
Endif ' end check armor worn
Else ' end check ring worn
If Weapon1 Then ' check armor worn, ring not
Outpt=Outpt+"." ' append period
Call IO.O ' display only armor worn
Endif ' end check armor, ring
Endif ' end check ring worn
Outpt=Nul ' clear display string
If Weapon2 Or Weapon3 Then ' check either weapon or shield being held
Outpt="You are holding " ' initialize display string
If Weapon2 Then ' check weapon being held
Call Read.Record(TreasureFile,Abs(UserRecord.Inv(Weapon6))) 'get weapon
Outpt=Outpt+Rtrim$(TreasureRecord.TreasureName) ' record, append name
Endif ' end check weapon held
Endif ' end check either being held
If Weapon3 Then ' check shield being held
Call Read.Record(TreasureFile,Abs(UserRecord.Inv(Weapon5))) 'shield record
If Weapon2 Then ' check weapon held again
Outpt=Outpt+" and "+Rtrim$(TreasureRecord.TreasureName)+"." ' append
Call IO.O ' both items being held
Else ' weapon not held
Outpt="You are holding "+Rtrim$(TreasureRecord.TreasureName)+"."
Call IO.O ' display only shield being held
Endif ' end check weapon held
Else ' end check shield held
If Weapon2 Then ' check weapon held, not shield
Outpt=Outpt+"." ' append period
Call IO.O ' display only weapon held
Endif ' end check weapon, shield
Endif ' end check shield held
End Sub ' end routine to display player characteristics
Rem * routine to display player character alignment and health statistics.
Sub Display.Health
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Call Show.Align ' routine to display alignment
Call Show.Health ' routine to display health statistics
End Sub ' end routine to display alignment/health
Rem * routine to display health statistics, and weapon, shield, armor plus.
Sub Show.Health
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
' display vital health statistics in percentage form
Outpt="Vitals: " ' make output message
Var1#=Cdbl(UserRecord.FatigueMax) ' calculate total hits
Var1#=Var1#+Cdbl(+UserRecord.VitalityMax) ' calculate total hits
Var2#=Cdbl(UserRecord.Fatigue) ' calculate hits remaining
Var2#=Var2#+Cdbl(+UserRecord.Vitality) ' calculate hits remaining
Outpt=Outpt+"Body" ' append health message
If Var1#=0# Then ' check divide by zero
Temp#=0# ' reset health hits
Else ' check divide
Temp#=((Var2#/Var1#)*.40#)*100# ' compute health percentage
Temp#=Int(Temp#) ' compute health integer
If Temp#<1.0# Then ' check percentage
Temp#=1.0# ' reset percentage
Endif ' end check percentage
Endif ' end check divide by zero
If Temp#<0# Then ' check overflow
Temp#=0# ' reset percentage
Endif ' end ceck overflow
Outpt=Outpt+Str$(Temp#)+"%" ' append health percentage
Outpt=Outpt+" Arms" ' append health message
If Var1#=0# Then ' check divide by zero
Temp#=0# ' reset health hits
Else ' check divide
Temp#=((Var2#/Var1#)*.25#)*100# ' compute health percentage
Temp#=Int(Temp#)
If Temp#<1.0# Then ' check percentage
Temp#=1.0# ' reset percentage
Endif ' end check percentage
Endif ' end check divide by zero
If Temp#<0# Then ' check overflow
Temp#=0# ' reset percentage
Endif ' end ceck overflow
Outpt=Outpt+Str$(Temp#)+"%" ' append health percentage
Outpt=Outpt+" Legs" ' append health message
If Var1#=0# Then ' check divide by zero
Temp#=0# ' reset health hits
Else ' check divide
Temp#=((Var2#/Var1#)*.25#)*100# ' compute health percentage
Temp#=Int(Temp#)
If Temp#<1.0# Then ' check percentage
Temp#=1.0# ' reset percentage
Endif ' end check percentage
Endif ' end check divide by zero
If Temp#<0# Then ' check overflow
Temp#=0# ' reset percentage
Endif ' end ceck overflow
Outpt=Outpt+Str$(Temp#)+"%" ' append health percentage
Outpt=Outpt+" Head" ' append health message
If Var1#=0# Then ' check divide by zero
Temp#=0# ' reset health hits
Else ' check divide
Temp#=((Var2#/Var1#)*.10#)*100# ' cmpute health percentage
Temp#=Int(Temp#)
If Temp#<1.0# Then ' check percentage
Temp#=1.0# ' reset percentage
Endif ' end check percentage
Endif ' end check divide by zero
If Temp#<0# Then ' check overflow
Temp#=0# ' reset percentage
Endif ' end ceck overflow
Outpt=Outpt+Str$(Temp#)+"%" ' append health percentage
Call IO.O ' send output
' health statistics line one contains vitals in form:
' Vitals: Fat 10/10(+10) Vit 10/10 Mag 10/10 Psi 10/10
If Weapon1 Or Weapon3 Then ' check armor, shield
' add pluses to message
Weapon.Plus$="(+"+Mid$(Str$(Weapon1+Weapon3),2)+")"
Else ' neither armor, shield
Weapon.Plus$=Nul ' clear plusses message
Endif ' end check armor, shield
Outpt="Vital hits:" ' initialize health one line
' append current fatigue and maximum fatigue
Outpt=Outpt+" Fat" ' append stat name
Outpt=Outpt+Str$(UserRecord.Fatigue)+"/"+Mid$(Str$(UserRecord.FatigueMax),2)
Outpt=Outpt+Weapon.Plus$ ' append plusses message
' append current vitality and maximum vitality
Outpt=Outpt+" Vit" ' append stat name
Outpt=Outpt+Str$(UserRecord.Vitality)+"/"+Mid$(Str$(UserRecord.VitalityMax),2)
' append current magic points and maximum magic points
Outpt=Outpt+" Mag" ' append stat name
Outpt=Outpt+Str$(UserRecord.Magic)+"/"+Mid$(Str$(UserRecord.MagicMax),2)
' append current psionic points and maximum psionic points
Outpt=Outpt+" Psi" ' append stat name
Outpt=Outpt+Str$(UserRecord.Psionic)+"/"+Mid$(Str$(UserRecord.PsionicMax),2)
Call IO.O ' display vitals message line
' health statistics line two contains vitals in form:
' Stats: Str 10(+10) Int 10 Wis 10 Dex 10 Con 10 Pie 10 Cha 10
Outpt="Stats: " ' initialize vitals message
For Array.Index=1 To 7 ' loop through all health statistics
' append first three letters of statistics name and player statistic value
Outpt=Outpt+Left$(Stat(Array.Index),3)+Str$(UserRecord.Stats(Array.Index))
If Array.Index=1 Then ' check strength selected
If Weapon2 Then ' verify weapon being held
Outpt=Outpt+"(+"+Mid$(Str$(Weapon2),2)+")" ' append weapon plus
Endif ' end check weapon
Endif ' end check strength
Outpt=Outpt+" " ' append one space
Next ' end loop through health statistics
Call IO.O ' display vitals message line
' health statistics line three contains vitals in form:
' Weapons: Blunt> 0% Pole> 0% Sharp> 10% Thrusting> 0%
Outpt="Weapons: " ' initialize vitals message
For Weapon.Number=1 To 4 ' loop through all weapon classes
Weapon$=Rtrim$(Weapon.Type.Name(Weapon.Number)) ' make weapon name
Mid$(Weapon$,1,1)=Ucase$(Mid$(Weapon$,1,1)) ' make weapon name
Outpt=Outpt+Weapon$ ' append weapon class name
' append player weapon class percentage value
Outpt=Outpt+Str$(UserRecord.Weapons(Weapon.Number))+"% "
Next ' loop through weapon classes
Call IO.O ' display vitals message line
' display lady statistics
If UserRecord.ClassType=Lady Then ' compare user class type to lady
' make message for lady statistics
Outpt="Lady stats: Beauty "+Str$(UserRecord.Beauty) ' append beauty value
Outpt=Outpt+" Glamour "+Str$(UserRecord.Glamour) ' append glamour value
Call IO.O ' send lady statistics message
Endif ' end compare user class type
End Sub ' end routine to display health statistics
Rem * routine to display player character alignment.
Sub Show.Align
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
If UserRecord.Level<=False Then ' check user level
Outpt="You are dead!" ' make user level message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end check user level
Outpt="You are a level"+Str$(UserRecord.Level) ' make user level message
If UserRecord.Race<=False Then ' check valid user race
UserRecord.Race=1 ' reset user race
Endif ' end check valid user race
Outpt=Outpt+" "+Rtrim$(Race(UserRecord.Race))+" " ' append user race name
Inpt=UserRecord.ClassName ' store user class name
Call Decrypt(Inpt) ' decrypt class name
Outpt=Outpt+Inpt ' append classname
Call IO.O ' send user type message
Outpt="You are aligned " ' make aligned message
' append player alignment type name 1 through 3 (-1,0,1 plus 2) number 1
Outpt=Outpt+Rtrim$(Alignment.Name1(UserRecord.Align1+2))+" "
' append player alignment type name 1 through 3 (-1,0,1 plus 2) number 2
Outpt=Outpt+Rtrim$(Alignment.Name2(UserRecord.Align2+2))+"."
Call IO.O ' send player alignment message
End Sub ' end routine to display player character alignment
Rem * DM routine to display status of system.
Sub Display.Memory
On Local Error Resume Next ' local error resume
Graphics.Off=False ' reset color
Outpt="Dnddoor Author: "+Author$ ' get author name
Call IO.O ' display author name string
Call System.Type ' get system type
Graphics.Off=True ' reset color
Outpt="This System: "+Outpt
Call IO.O ' display system status message
Call Free.Disk.Space ' get free disk space
Outpt="Free disk space: "+Outpt+"."
Call IO.O ' display system status message
' make message with stack memory
Outpt="Free Stack Space: "
Outpt=Outpt+Format$(Fre(-2),"#,##0;;")+" B."
Call IO.O ' display message
' make message with far memory
Outpt="Free String Space: "
Outpt=Outpt+Format$(Fre("a"),"#,##0;;")+" B."
Call IO.O ' display message
If Share.Installed Then
Outpt="Share installed."
Call IO.O
Endif
End Sub ' end DM routine to display system memory
Rem * routine returns operating system type in Outpt.
'--------D-2130-------------------------------
'INT 21 - DOS 2+ - GET DOS VERSION
' AH = 30h
'---DOS 5+ ---
' AL = what to return in BH
' 00h OEM number (as for DOS 2.0-4.0x)
' 01h version flag
'Return: AL = major version number (00h if DOS 1.x)
' AH = minor version number
' BL:CX = 24-bit user serial number (most versions do not use this)
'Notes: the OS/2 v1.x Compatibility Box returns major version 0Ah (10)
' the OS/2 v2.x Compatibility Box returns major version 14h (20)
' the Windows/NT DOS box returns version 5.00, subject to SETVER
'--------W-2F160A-----------------------------
'INT 2F - MS Windows 3.1 - IDENTIFY WINDOWS VERSION AND TYPE
' AX = 160Ah
'Return: AX = 0000h if call supported
' BX = version (BH=major, BL=minor)
' CX = mode (0002h = standard, 0003h = enhanced)
Sub System.Type
On Local Error Resume Next ' local error resume
Inregs.AX=&H2B01 ' setup for dos function call
Inregs.CX=&H4445 ' desqview operating
Inregs.DX=&H5351 ' parameters
Call Interrupt(&H21,Inregs,Outregs) ' call dos function
If (Outregs.AX And &HFF)<>&HFF Then ' check system type
Outpt="Desqview." ' make display message
Exit Sub ' exit from routine
Endif ' end check system type
Inregs.AX=&HE400 ' setup for dos function call
Call Interrupt(&H21,Inregs,Outregs) ' call dos function
If (Outregs.AX And &HFF)>&H00 Then ' check system type
Outpt="DoubleDos." ' make display message
Exit Sub ' exit from routine
Endif ' end check system type
Inregs.AX=&H3001 ' setup for dos function call
Call Interrupt(&H21,Inregs,Outregs) ' call dos function
DOS.Major=Outregs.AX And &HFF ' store low order bytes
DOS.Minor=(Outregs.AX And &HFF00)/256 ' store high order bytes
Inregs.AX=&H160A ' setup for dos function call
Call Interrupt(&H2F,Inregs,Outregs) ' call dos function
If Outregs.AX=False Then ' check windows installed
Win.Minor=Outregs.BX And &HFF ' get windows version low byte
Win.Major=(Outregs.BX And &HFF00)/256 ' get windows version high byte
If Win.Major=4 Then ' verify windows
If Win.Minor=10 Then ' verify windows type
Outpt="Windows 98." ' make display message
Else ' check type
Outpt="Windows 95." ' make display message
Endif ' end check windows type
Else ' check windows version
' store windows 3.x version
Outpt="Windows"+Str$(Win.Major)+"."+Ltrim$(Str$(Win.Minor))
Endif ' end check windows type
Else ' check other versions
Select Case DOS.Major ' check os/2 version
Case 10 ' check os/2
Outpt="OS/2 v1.0" ' store os/2 version
Case 20 ' check os/2
If DOS.Minor=30 Then ' check os/2 minor
Outpt="OS/2 v3.0" ' store os/2 version
Else ' check os/2 minor
Outpt="OS/2 v2.0" ' store os/2 version
Endif ' end check os/2 minor
Case Else ' remaining version must be dos
' store dos version
Outpt="DOS"+Str$(DOS.Major)+"."+Mid$(Str$(DOS.Minor),2)
End Select ' end check version
Endif ' end check any version
End Sub ' end routine
Rem * routine returns free disk space in Outpt.
Rem * processing variables:
Rem * Struc - returns FAT32 free disk space information.
Rem * ASCIZ - stores current drive letter.
Rem * Fat32.Flag - true if fat32 disk space calculated.
'INT 2F - MS Windows 3.1 - IDENTIFY WINDOWS VERSION AND TYPE
' AX = 160Ah
'Return: AX = 0000h if call supported
' BX = version (BH=major, BL=minor)
' CX = mode (0002h = standard, 0003h = enhanced)
'INT 21 - DOS 2+ - GET FREE DISK SPACE
' AH = 36h
' DL = drive number (00h = default, 01h = A:, etc)
'Return: AX = FFFFh if invalid drive
' else
' AX = sectors per cluster
' BX = number of free clusters
' CX = bytes per sector
' DX = total clusters on drive
'Notes: free space on drive in bytes is AX * BX * CX
' total space on drive in bytes is AX * CX * DX
'INT 21 - Windows95 - FAT32 - GET EXTENDED FREE SPACE ON DRIVE
' AX = 7303h
' DS:DX -> ASCIZ string for drive ("C:\" or "\\SERVER\Share")
' ES:DI -> buffer for extended free space structure (see #01789)
' CX = length of buffer for extended free space
'Return: CF clear if successful
' ES:DI buffer filled
' CF set on error
' AX = error code
' on DOS versions which do not support the FAT32 calls, this function
' returns CF clear/AL=00h (which is the DOS v1+ method for reporting
' unimplemented functions)
'Format of extended free space structure: (returned in Struc):
'Offset Size Description (Table 01789)
' 00h WORD (ret) size of returned structure
' 02h WORD (call) structure version (0000h)
' (ret) actual structure version (0000h)
' 04h DWORD number of sectors per cluster (with adjustment for compression)
' 08h DWORD number of bytes per sector
' 0Ch DWORD number of available clusters
' 10h DWORD total number of clusters on the drive
' 14h DWORD number of physical sectors available on the drive, without
' adjustment for compression
' 18h DWORD total number of physical sectors on the drive, without
' adjustment for compression
' 1Ch DWORD number of available allocation units, without adjustment
' for compression
' 20h DWORD total allocation units, without adjustment for compression
' 24h 8 BYTEs reserved
Sub Free.Disk.Space
On Local Error Resume Next ' local error resume
Dim Struc As String*44, ASCIZ As String*4 ' fat32 structure strings
Inregs.AX=&H3600 ' setup for dos function call
Inregs.DX=&H0000 ' setup for dos function call
Call Interrupt(&H21,Inregs,Outregs) ' call dos function
If Outregs.AX=&HFFFF Then ' check error status
Outpt="<n/a>" ' make unknown message
Exit Sub ' exit routine
Endif ' end check error status
' check windows
Inregs.AX=&H160A ' store function data
Call Interrupt(&H2F,Inregs,Outregs) ' call dos function
Fat32.Flag=False ' reset disk space flag
If Outregs.AX=False Then ' check return error status
TempD$=Left$(Curdir$,1) ' get default drive letter
ASCIZ=TempD$+":\"+CHR$(0) ' store drive letter
Inregs.AX=&H7303 ' dos function for fat32
Inregs.DS=VARSEG(ASCIZ) ' pointer to drive variable
Inregs.DX=VARPTR(ASCIZ) ' pointer to drive variable
Inregs.ES=VARSEG(Struc) ' pointer to fat32 structure string
Inregs.DI=VARPTR(Struc) ' pointer to fat32 structure string
Inregs.CX=44 ' length of string
Call Interrupt(&H21,Inregs,Outregs) ' dos functino call
' check for fat32
If (Outregs.Flags And &H1)=&H0 THEN ' test error status
If (Outregs.AX And &HFF)>0 THEN ' test error status
' get disk space beyond 2 GB.
Bytes#=Clng(Asc(Mid$(Struc,9,1)))
Bytes#=Bytes#+Clng(Asc(Mid$(Struc,10,1)))*256#
Bytes#=Bytes#+Clng(Asc(Mid$(Struc,11,1)))*65536#
Bytes#=Bytes#+Clng(Asc(Mid$(Struc,12,1)))*16777216#
Sectors#=ClnG(Asc(Mid$(Struc,21,1)))
Sectors#=Sectors#+Clng(Asc(Mid$(Struc,22,1)))*256#
Sectors#=Sectors#+Clng(Asc(Mid$(Struc,23,1)))*65536#
Sectors#=Sectors#+Clng(Asc(Mid$(Struc,24,1)))*16777216#
Disk.Space#=Bytes#*Sectors# ' store fat32 free disk space
Fat32.Flag=True ' set disk space flag
Endif
Endif
Endif
If Fat32.Flag=False Then ' check fat32 flag
Inregs.AX=&H3600 ' setup for dos function call
Inregs.DX=&H0000 ' setup for dos function call
Call Interrupt(&H21,Inregs,Outregs) ' call dos function
If Outregs.AX<False Then ' check high bit integer wrap
Sectors#=Cdbl(Outregs.AX+65536) ' increment off twos-complement bit
Else ' check high bit
Sectors#=Cdbl(Outregs.AX) ' store sectors
Endif ' end check high bit
If Outregs.BX<False Then ' check high bit integer wrap
Clusters#=Cdbl(Outregs.BX+65536) ' increment off twos-complement bit
Else ' check high bit
Clusters#=Cdbl(Outregs.BX) ' store clusters
Endif ' end check high bit
If Outregs.CX<False Then ' check high bit integer wrap
Bytes#=Cdbl(Outregs.CX+65536) ' increment off twos-complement bit
Else ' check high bit
Bytes#=Cdbl(Outregs.CX) ' stores bytes
Endif ' end check high bit
Disk.Space#=Sectors#*Clusters#*Bytes# ' calculate actual free disk space
Endif ' end check fat32 flag
Byte.Counter=False ' reset kilo counter
' loop until disk space is an even kilo type
Do ' start division loop
If Disk.Space#>=1024 Then ' compare disk space to one kilobyte
Disk.Space#=Disk.Space#/1024 ' integer divide disk space
Byte.Counter=Byte.Counter+1 ' increment kilo type counter
If Byte.Counter=4 Then ' check kilos greater than a terabyte
Exit Do ' exit if too large
Endif ' end check terabyte
Else ' check smallest division
Exit Do ' exit if division is smallest
Endif ' end check kilobyte
Loop ' end division loop
Outpt=Format$(Disk.Space#,"#,##0.00;;") ' format the disk space
Select Case Byte.Counter ' determine the kilo type
Case 0 ' byte case
Outpt=Outpt+" B" ' append size
Case 1 ' kilobyte case
Outpt=Outpt+" KB" ' append size
Case 2 ' megabyte case
Outpt=Outpt+" MB" ' append size
Case 3 ' gigabyte case
Outpt=Outpt+" GB" ' append size
Case 4 ' terabyte case
Outpt=Outpt+" TB" ' append size
End Select ' end determine the kilo type
End Sub ' end routine
Rem * routine to display extended information on an object, treasure,
Rem * monster, or container using the identify command.
Sub Identify.Object
On Local Error Resume Next ' local error resume
If Normal.User Then ' check non DM status
If UserRecord.Level<=4 Then ' check player level
Outpt="You are not high enough level!" ' make message
Call IO.O ' send message
Exit Sub ' exit routine
Endif ' end check level
Endif ' end check DM status
Call Display.Information ' routine to display information on an item
End Sub ' end identify routine
Rem * routine to display current time, user's time on, and user's time left.
Rem * input variables:
Rem * Time.On - containing the user time on in system time format hh:mm:ss.
Rem * Time.Left - containing the user's time limit in seconds from login.
Rem * processing variables:
Rem * OnTime# - contains serial number format of time calculations.
Rem * Hours - contains hours since login.
Rem * Minutes - contains minutes since login.
Rem * Seconds - contains seconds since login.
Sub Time.Online
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Outpt="It is now "+FNclock$+"." ' make display message
Call IO.O ' send output message
OnTime#=TimeValue(Time$)-TimeValue(Time.On) ' calculate time online
If OnTime#<False Then ' check past midnight
OnTime#=OnTime#+TimeValue("12:00:00")*2 ' add 24 hours (86,400 seconds)
Endif ' end check past midnight
Outpt="You have been on for" ' format time display message
Time.DIsplay$=Nul ' time display message
Gosub Time.Display ' subroutine to display message
Hours=Int(Time.Left/3600!) ' calculate hours of time limit
Time.Calc=Time.Left-Hours*3600! ' calculate time minus hours
Minutes=Int(Time.Calc/60!) ' calculate minutes of time limit
Seconds=Time.Calc-Minutes*60! ' calculate seconds of time limit
OnTime#=TimeSerial(Hours,Minutes,Seconds)-OnTime# ' calculate time remaining
Outpt="You have" ' format time display message
Time.Display$=" remaining" ' time display message
Gosub Time.Display ' subroutine to display message
Exit Sub ' exit routine
' subroutine to display time message
Time.Display:
If Hour(OnTime#)>0 Then ' compare hours of serial time variable
Outpt=Outpt+Str$(Hour(OnTime#))+" hours," ' append hours to string
Endif ' end compare hours
If Minute(OnTime#)>0 Then ' compare minutes of serial time variable
Outpt=Outpt+Str$(Minute(OnTime#))+" minutes," ' append minutes to string
Endif ' end compare minutes
If Second(OnTime#)>0 Then ' compare seconds of serial time variable
Outpt=Outpt+Str$(Second(OnTime#))+" seconds," ' append seconds to string
Endif ' end compare seconds
Outpt=Left$(Outpt,Len(Outpt)-1) ' trim trailing comma
Outpt=Outpt+Time.DIsplay$+"." ' combine message
Call IO.O ' send output message
Return ' exit time display subroutine
End Sub ' end routine to display time on
Rem * routine to display list of weapons for sale, the first 15 items in the
Rem * treasure file.
Sub Weapon.List
On Local Error Resume Next ' local error resume
Graphics.Off=False ' reset color
Outpt="The Blacksmith says: Here's a list of my inventory." ' message
Call IO.O ' send output message
Graphics.Off=True ' reset color
Outpt="To purchase, enter number to buy, for example: Buy 15." ' make message
Call IO.O ' send output message
Graphics.Off=False ' reset color
Outpt="Number Weapon Weight Plus Gold" ' make output
Call IO.O ' send output message
Allow.Break=True ' allow control-k breaking
Break=False ' reset control-k flag
Graphics.Off=True ' reset color
For List.Count=1 To 20 ' loop through the first 20 treasure items
Call Read.Record(TreasureFile,List.Count) ' get the next treasure record
Item.Weight=TreasureRecord.Weight ' store the treasure item weight
Gold.Value#=TreasureRecord.Gold ' store the treasure item gold value
' store the treasure name
WeaponList.Output$=TreasureRecord.TreasureName
' set first character uppercase
Mid$(WeaponList.Output$,1,1)=Ucase$(Mid$(WeaponList.Output$,1,1))
Weapon.Plus=False ' reset plus
If TreasureRecord.Spell Then ' compare item to spell
Call Read.Record(SpellFile,TreasureRecord.Spell) ' get spell record
Weapon.Plus=SpellRecord.Level ' store spell level of item
Else ' end compare spell item
If TreasureRecord.Plus Then ' compare treasure item plus
Weapon.Plus=Abs(TreasureRecord.Plus) ' store item plus
Endif ' end compare treasure item plus
Endif ' end compare item spell plus
' combine the treasure weight, gold value, and name with blanks imbedded
Outpt=Mid$(Str$(List.Count),2) ' append item value
Outpt=Outpt+Space$(8-Len(Str$(List.Count))) ' pad blanks
Outpt=Outpt+WeaponList.Output$ ' append item value
Outpt=Outpt+Space$(21-Len(WeaponList.Output$)) ' pad blanks
Outpt=Outpt+Mid$(Str$(Item.Weight),2) ' append item value
Outpt=Outpt+Space$(8-Len(Str$(Item.Weight))) ' pad blanks
Outpt=Outpt+Mid$(Str$(Weapon.Plus),2) ' append item value
Outpt=Outpt+Space$(8-Len(Str$(Weapon.Plus))) ' pad blanks
Outpt=Outpt+Mid$(Str$(Gold.Value#),2) ' append item value
Call IO.O ' send message output
If Break Then ' check break
Exit For ' exit treasure file loop
Endif ' end compare break
Next ' end treasure file item display loop
Allow.Break=False ' reset control-k breaking
If Break Then ' check control-k flag
Break=False ' reset control-k flag
Outpt=Nul ' set output to null
Call IO.O ' send empty return
Endif ' end check control-k flag
End Sub ' end routine to list treasure items for sale
Rem * routine to allow user to change password.
Sub Change.PassWord
On Local Error Resume Next ' local error resume
Graphics.Off=True ' reset color
Outpt="Change your password(y/n)? " ' input prompt
No.Input.Out="N" ' default input
Call IO.I ' get user input
If Yes Then ' compare input
Outpt="Type in old password for verification:" ' input prompt
Line.Length=20 ' line length for password
Hidden=True ' echo mask characters
Call IO.I ' get user input
Hidden=False ' reset echo mask flag
Inpt=Ltrim$(Inpt) ' trim entry password
Inpt=Rtrim$(Inpt) ' trim entry password
Inpt=Ucase$(Inpt) ' set entry password to uppercase
Outpt=UserRecord.PassWord ' get user's current password
Call Decrypt(Outpt) ' decrypt user password
If Outpt=Nul Then ' verify password validity
Outpt="This password has a checksum error!" ' make error message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end compare password validity
Outpt=Rtrim$(Outpt) ' trim password
If Outpt<>Inpt Then ' compare entered password to user password
Outpt="Passwords don't match!" ' make error message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end compare passwords
Outpt="Type in new password(20 char. max.)" ' format input message
Call IO.O ' send output message
Line.Length=20 ' set line length of new password
Outpt="?" ' set input prompt
Hidden=True ' set echo mask character flag
Call IO.I ' get user input
Hidden=False ' reset echo mask flag
If No.Input Then ' check length of input
Outpt="Password not changed." ' make error message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end compare length of input
Inpt=Ltrim$(Inpt) ' trim new password
Inpt=Rtrim$(Inpt) ' trim new password
Inpt=Ucase$(Inpt) ' convert to uppercase
Call Valid(Inpt,20) ' check validity of new password
If Inpt=Nul Then ' compare validity of new password
Outpt="Illegal characters in password!" ' make error message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end compare password validity
Call Encrypt(Inpt,False) ' encrypt new password
UserRecord.PassWord=Inpt ' store new password in user record
Outpt="Password changed." ' make message
Call IO.O ' send output message
Exit Sub ' exit routine
Endif ' end compare input
Outpt="Password not changed." ' make message
Call IO.O ' send output message
End Sub ' end routine to change password
Rem * routine to change alignment once per player character.
Sub Align
On Local Error Resume Next ' local error resume
If Normal.User Then ' compare to non DM
If UserRecord.Flags And Alignmented Then ' compare user record flag
Outpt="You've already changed alignment once!" ' message
Call IO.O ' send output
Exit Sub ' exit routine
Endif ' end compare user record flag
Endif ' end compare normal user
Outpt="Change alignment(y/n)? " ' input prompt
No.Input.Out="Y" ' default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
UserRecord.Flags=UserRecord.Flags Or Alignmented ' set user record flag
Call Modify.Alignment ' routine to change alignment
Outpt="Alignment is now " ' message with new alignment
Outpt=Outpt+Rtrim$(Alignment.Name1(UserRecord.Align1+2))+" " ' message
Outpt=Outpt+Rtrim$(Alignment.Name2(UserRecord.Align2+2)) ' message
Call IO.O ' send message
Exit Sub ' exit routine
Endif ' end compare input
Outpt="Alignment not changed!" ' make output message
Call IO.O ' send output message
End Sub ' end routine to change alignment
Rem * routine to allow user to change all statistics once per character.
Sub Reroll.Character
On Local Error Resume Next ' local error resume
If Normal.User Then ' compare to non DM
If UserRecord.Flags And Rerolled Then ' check user record flag
Outpt="You've already rerolled your character!" ' message
Call IO.O ' send output
Exit Sub ' exit routine
Endif ' end compare user flag
Endif ' end compare normal user
Outpt="Reroll character(y/n)? " ' prompt user to reroll
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
UserRecord.Flags=UserRecord.Flags Or Rerolled ' set user record flag
Do ' loop until changes completed
Outpt="Character reroll:" ' message
Call IO.O ' send output
Outpt="Change class type/name(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Call Modify.Class ' routine to modify class type
Endif ' end compare yes entered
Outpt="Character reroll:" ' message
Call IO.O ' send output
Outpt="Change vital statistics(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Call Modify.Stats ' routine to modify statistics
Endif ' end compare yes entered
Outpt="Character reroll:" ' message
Call IO.O ' send output
Outpt="Change character race type/name(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Call Modify.Race ' routine to modify race
Endif ' end compare yes entered
Outpt="Character reroll:" ' message
Call IO.O ' send output
Outpt="Change weapon proficiency(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Call Modify.Proficiency ' routine to modify weapon proficiency
Endif ' end compare yes entered
Outpt="Character reroll:" ' message
Call IO.O ' send output
Outpt="Change character alignment(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Call Modify.Alignment ' routine to modify alignment
Endif ' end compare yes entered
Do ' loop until changes finished prompt
Outpt="All changes finished(y/n)? " ' input prompt
No.Input.Out="Y" ' set default input
Call IO.I ' get user input
If Yes Then ' compare yes entered
Exit Sub ' exit routine
Endif ' end compare
If No Then ' compare no entered
Exit Do ' exit changes loop
Endif ' end compare
Loop ' loop until yes or no entered
Loop ' end loop until changes completed
Exit Sub ' exit routine
Endif ' end compare yes entered
Outpt="Your character has not been rerolled!" ' make output message
Call IO.O ' send output message
End Sub ' end routine to modify all statistics
Rem * routine returns a prefix for monster name.
Rem * output variables:
Rem * Prefix1 - monster name prefix.
Sub The.Or.An
On Local Error Resume Next ' local error resume
If MonsterArray(Monster.Number).Permanent<True Then ' check for nonplayer
Prefix1="the " ' make prefix
Else ' check monster type
Prefix$=MonsterArray(Monster.Number).MonsterName ' get monster name
Prefix$=Left$(Prefix$,1) ' get first letter of monster name
If Instr("aeiou",Prefix$) Then ' check monster name vowel
Prefix1="an " ' set prefix
Else ' check vowel
Prefix1="a " ' set prefix
Endif ' end check monster name vowel
Endif ' end check nonplayer
End Sub ' end routine to get monster name prefix
Rem * routine for parsing numeric value from parameter.
Rem * input variables:
Rem * Parsed.Command1 - string with imbedded pound sign to check.
Rem * output variables:
Rem * Parse.Number - value of number after pound sign.
Rem * work variables:
Rem * Delimit - position of # sign.
Sub Numeric
On Local Error Resume Next ' local error resume
Parse.Number=False ' reset numeric value
Parse.Delimit=Instr(Parsed.Command1,"#") ' search parameter for # sign
If Parse.Delimit Then ' check # sign in string
' store numeric value after #
Parse.Number=Int(Val(Mid$(Parsed.Command1,Parse.Delimit+1)))
' trim # from string
Parsed.Command1=Left$(Parsed.Command1,Parse.Delimit-1)
Endif ' end check for # sign in string
End Sub ' end routine to parse part of parameter
Rem * routine decrements parameter # value after calls to search routines.
Rem * input variables:
Rem * Parse.Count - counter for search routines.
Rem * output variables:
Rem * Parse.Number - decremented # sign value counter.
Sub Num
On Local Error Resume Next ' local error resume
If Parse.Number>False Then ' check counter
' decrement search routine value from counter
Parse.Number=Parse.Number-Parse.Count
If Parse.Number<False Then ' check counter
Parse.Number=False ' reset counter
Endif ' end check counter
Endif ' end check counter
End Sub ' end routine to decrement # sign value counter
Rem * routine to separate two parameters after command input.
Rem * input variables:
Rem * Parsed.Command2 - first/second parameters combined.
Rem * output variables:
Rem * Parsed.Command1 - first parsed parameter.
Rem * Parsed.Command2 - second parsed parameter.
Rem * work variables:
Rem * Delimit - position of # sign.
Sub Parse
On Local Error Resume Next ' local error resume
' find imbedded space in command parameter
Parse.Delimit=Instr(Parsed.Command2," ")
Parser=False ' reset position of space
If Parse.Delimit Then ' check imbedded space
' store first parameter
Parsed.Command1=Left$(Parsed.Command2,Parse.Delimit-1)
' store second parameter
Parsed.Command2=Mid$(Parsed.Command2,Parse.Delimit+1)
Parser=Parse.Delimit ' store parsed space position
Endif ' end check for space
End Sub ' end routine to separate parameters
Rem * routine to separate two parameters after command input in reverse order.
Rem * input variables:
Rem * Parsed.Command2 - first/second parameters combined.
Rem * output variables:
Rem * Parsed.Command1 - second parsed parameter.
Rem * Parsed.Command2 - first parsed parameter.
Rem * work variables:
Rem * Delimit - position of # sign.
Sub ParseX
On Local Error Resume Next ' local error resume
' find imbedded space in command parameter
Parse.Delimit=Instr(Parsed.Command2," ")
Parser=False ' reset position of space
If Parse.Delimit Then ' check imbedded space
' store second parameter
Parsed.Command1=Mid$(Parsed.Command2,Parse.Delimit+1)
' store first parameter
Parsed.Command2=Left$(Parsed.Command2,Parse.Delimit-1)
Parser=Parse.Delimit ' storeparsed space position
Endif ' end check for space
End Sub ' end routine to separate parameters in reverse order
Rem * routine computes gold player needs for next training level.
Rem * output variables:
Rem * Gold.Required# - gold points.
Sub Gold(Gold.Required#)
On Local Error Resume Next ' local error resume
If UserRecord.Level<=10 Then ' check player level
Gold.Required#=2^(UserRecord.Level+5) ' calculate gold
Else ' player level over ten
Gold.Required#=2^15+(UserRecord.Level-10)*10000! ' calculate gold
Endif ' end check player level
End Sub ' end routine to calculate gold
Rem * routine computes experience player needs for next training level.
Rem * output variables:
Rem * Exp.Required# - experience points.
Sub Experience(Exp.Required#)
On Local Error Resume Next ' local error resume
If UserRecord.Level<=10 Then ' check player level
Exp.Required#=2^(UserRecord.Level+6) ' calculate experience
Else ' player level over ten
Exp.Required#=2^16+(UserRecord.Level-10)*10000! ' calculate experience
Endif ' end check player level
End Sub ' end routine to calculate experience
Rem * routine returns range of numbers.
Rem * input variables:
Rem * Upper.Range - contains upper range.
Rem * output variables:
Rem * Start.Range - start of range.
Rem * End.Range - end of range.
Sub Get.Range(Upper.Range,Start.Range,End.Range)
On Local Error Resume Next ' local error resume
Range.Type$=Mid$(Str$(Upper.Range),2) ' convert upper range to string
Outpt="From(1-"+Range.Type$+")? " ' make input prompt
No.Input.Out="1" ' default input
Call IO.I ' get input
Start.Range=Int(Val(Inpt)) ' convert input to integer
If Start.Range<1 Then ' check bounds of input
Start.Range=1 ' reset input
Endif ' end check bounds
If Start.Range>Upper.Range Then ' check bounds of input
Start.Range=Upper.Range ' reset input
Endif ' end check bounds
Outpt="To("+Mid$(Str$(Start.Range),2)+"-"+Range.Type$+")? " ' input prompt
No.Input.Out=Range.Type$ ' default input
Call IO.I ' get input
End.Range=Int(Val(Inpt)) ' convert input to integer
If End.Range<Start.Range Then ' check bounds
End.Range=Start.Range ' reset input
Endif ' end check bounds
If End.Range>Upper.Range Then ' check bounds
End.Range=Upper.Range ' reset input
Endif ' end check bounds
End Sub ' end routine to get range of numbers
Rem * routine returns range of numbers.
Rem * input variables:
Rem * Start.Range - starting of range.
Rem * End.Range - end of range.
Rem * output variables:
Rem * Upper.Range - contains upper range.
Sub Get.Range2(Start.Range,End.Range,Upper.Range)
On Local Error Resume Next ' local error resume
Start.Range$=Mid$(Str$(Start.Range),2) ' convert starting range to string
End.Range$=Mid$(Str$(End.Range),2) ' convert upper range to string
Outpt=Outpt+"("+Start.Range$+"-"+End.Range$+")? " ' make input prompt
No.Input.Out=Start.Range$ ' default input
Call IO.I ' get input
Upper.Range=Int(Val(Inpt)) ' convert input to integer
If Upper.Range<Start.Range Then ' check bounds of input
Upper.Range=Start.Range ' reset input
Endif ' end check bounds
If Upper.Range>End.Range Then ' check bounds of input
Upper.Range=End.Range ' reset input
Endif ' end check bounds
End Sub ' end routine to get range of numbers
Rem * routine returns range of single precision numbers.
Rem * input variables:
Rem * Upper.Range! - contains upper range.
Rem * output variables:
Rem * Start.Range! - start of range.
Rem * End.Range! - end of range.
Sub Get.Room.Range(Upper.Range!,Start.Range!,End.Range!)
On Local Error Resume Next ' local error resume
Range.Type$=Mid$(Str$(Upper.Range!),2) ' convert upper range to string
Outpt="From(1-"+Range.Type$+")? " ' make input prompt
No.Input.Out="1" ' default input
Call IO.I ' get input
Start.Range!=Int(Val(Inpt)) ' convert input to integer
If Start.Range!<1! Then ' check bounds of input
Start.Range!=1! ' reset input
Endif ' end check bounds
If Start.Range!>Upper.Range! Then ' check bounds of input
Start.Range!=Upper.Range! ' reset input
Endif ' end check bounds
Outpt="To("+Mid$(Str$(Start.Range!),2)+"-"+Range.Type$+")? " ' input prompt
No.Input.Out=Range.Type$ ' default input
Call IO.I ' get input
End.Range!=Int(Val(Inpt)) ' convert input to integer
If End.Range!<Start.Range! Then ' check bounds
End.Range!=Start.Range! ' reset input
Endif ' end check bounds
If End.Range!>Upper.Range! Then ' check bounds
End.Range!=Upper.Range! ' reset input
Endif ' end check bounds
End Sub ' end routine to get range of numbers
Rem * routine returns range of single precision numbers.
Rem * input variables:
Rem * Start.Range - starting of range.
Rem * End.Range - end of range.
Rem * output variables:
Rem * Upper.Range - contains upper range.
Sub Get.Room.Range2(Start.Range!,End.Range!,Upper.Range!)
On Local Error Resume Next ' local error resume
Start.Range$=Mid$(Str$(Start.Range!),2) ' convert starting range to string
End.Range$=Mid$(Str$(End.Range!),2) ' convert upper range to string
Outpt=Outpt+"("+Start.Range$+"-"+End.Range$+")? " ' make input prompt
No.Input.Out=Start.Range$ ' default input
Call IO.I ' get input
Upper.Range!=Int(Val(Inpt)) ' convert input to integer
If Upper.Range!<Start.Range! Then ' check bounds of input
Upper.Range!=Start.Range! ' reset input
Endif ' end check bounds
If Upper.Range!>End.Range! Then ' check bounds of input
Upper.Range!=End.Range! ' reset input
Endif ' end check bounds
End Sub ' end routine to get range of numbers
Rem * routine returns the charges of an item of treasure.
Rem * output variables:
Rem * Charges.Amount - stores treasure type charges.
Sub TreasureCharges(Charges.Amount)
On Local Error Resume Next ' local error resume
Charges.Amount=TreasureRecord.Charges ' store treasure charges
If TreasureRecord.FuelType Then ' compare treasure to fuel
Charges.Amount=TreasureRecord.FuelCharges ' reset treasure charges
Endif ' end compare fuel charges
If TreasureRecord.LightType Then ' compare vehicle to light
Charges.Amount=False ' reset treasure charges
Endif ' compare charges
If TreasureRecord.Vehicle Then ' compare treasure to vehicle
Charges.Amount=TreasureRecord.VehicleHits ' reset treasure charges
Endif ' compare charges
End Sub ' end routine to return charges
Rem * routine to wish for an item
Rem * input variables:
Rem * Inpt - stores name of item
Sub Wish.Item
On Local Error Resume Next ' local error resume
Outpt="The Ghods Thunder.." ' make output message
Call IO.O ' send message
Outpt=" What Do You Wish For?" ' make input prompt
Call IO.I ' get input
Stored.Parsed.Command2=Inpt ' store input
Parsed.Command1=Stored.Parsed.Command2 ' store input
Call Numeric ' parse number
Inpt=Parsed.Command1 ' restore input
Inpt=Lcase$(Inpt) ' convert to lowercase
Call Drop(False) ' call routine to get item
End Sub
Rem * routine to wish for points or an item, or get an object or treasure.
Rem * input variables:
Rem * Drop.Type - false to use normal drop routine, true for extended drop.
Sub Drop(Drop.Type)
On Local Error Resume Next ' local error resume
Wish.Points=1 ' store points number to wish for
If Right$(Inpt,7)=" points" Then ' compare wish for two points
Inpt=Left$(Inpt,Len(Inpt)-7) ' truncate wish parameter
Wish.Points=2 ' store points number to wish for
Endif ' end compare points wish
For Stat.Number=1 To 7 ' loop through statistic names
Outpts=Stat(Stat.Number) ' get statistic name
Outpts=Rtrim$(Outpts) ' trim name
Outpts=Lcase$(Outpts) ' lowercase name
If Inpt=Outpts Then ' compare wish item to statistic name
If Normal.User Then ' check non DM
' check point already wished for
If (UserRecord.Flags And 2^Stat.Number) Then
Goto Wish.Denied ' jump to wish denied subroutine
Endif ' end check point wished for
Endif ' end check normal player
' add player wish bitflag
UserRecord.Flags=(UserRecord.Flags Or 2^Stat.Number)
Wish.Points=Wish.Points*Int(Rnd*3+1) ' calculate points to add
' calculate new statistic
New.Stat#=UserRecord.Stats(Stat.Number)+Wish.Points
If New.Stat#>MaxInt Then ' compare maximum integer
New.Stat#=MaxInt ' reset to maximum integer
Endif ' end check maximum integer
New.Stat=Cint(New.Stat#) ' store in integer
If Normal.User Then ' check non DM
If New.Stat>MaxStat Then ' check maximum statistic allowed
Goto Wish.Denied ' jump to wish denied subroutine
Endif ' end check maximum stat
Endif ' end check normal player
UserRecord.Stats(Stat.Number)=New.Stat ' increment point wished for
Graphics.Off=True ' reset color
Outpt="The Ghods Thunder..." ' make ghod message
Call IO.O ' send message
Outpt=" Your "+Outpts+" Has Been Raised!" ' make stat message
Call IO.O ' send update stat message
Graphics.Off=False ' reset color
Exit Sub ' exit routine
Endif ' end compare point wish
Next ' end loop through statistic names
If Drop.Type=False Then ' check drop type
If Normal.User Then ' check normal player
If UserRecord.Flags And Wished Then ' check player has already wished
Goto Wish.Denied ' jump to wish denied subroutine
Endif ' end check already wished
Endif ' end check normal user
Endif ' end check drop type
UserRecord.Flags=UserRecord.Flags Or Wished ' set player wish bitflag
Parse.Value=False ' item counter
Wish.Charges=False ' item charges
Wish.Index=False ' item index
' loop through treasure file
For Treasure.Number=1 To Lof(TreasureFile)/Len(TreasureRecord)
Call Read.Record(TreasureFile,Treasure.Number) ' get next record
Outpts=TreasureRecord.TreasureName ' store treasure name
Outpts=Left$(Outpts,Len(Inpt)) ' truncate name
If Inpt=Outpts Then ' compare treasure name to wish item name
Parse.Value=Parse.Value+1 ' increment item counter
' compare counters
If Parse.Number=False Or Parse.Value=Parse.Number Then
Wish.Index=Treasure.Number ' store treasure file number
Call TreasureCharges(Wish.Charges) ' routine to get treasure charges
Exit For ' exit loop through treasure file
Endif ' end compare counters
Endif ' end compare names
Next ' end loop through treasure file
If Wish.Index=False Then ' check no treasure match found
If Normal.User=False Or Drop.Type Then ' compare DM/Sysop or drop type
' loop through object file
For Object.Number=1 To Lof(ObjectFile)/Len(ObjectRecord)
Call Read.Record(ObjectFile,Object.Number) ' get object record
Outpts=ObjectRecord.ObjectName ' store object name
Outpts=Left$(Outpts,Len(Inpt)) ' truncate object name
If Inpt=Outpts Then ' compare object name to wish name
Parse.Value=Parse.Value+1 ' increment counter
' compare counters
If Parse.Number=False Or Parse.Value=Parse.Number Then
' store negation of object file index
Wish.Index=-Object.Number
Wish.Charges=False ' clear charges
Exit For ' exit loop through object file
Endif ' end compare counters
Endif ' end compare names
Next ' end loop through object file
Endif ' end compare drop type/DM, Sysop
Endif ' end check treasure found
If Drop.Type=False Then ' check drop type
If Wish.Index>False Then ' check treasure found
If Normal.User Then ' check normal player/not DM
If TreasureRecord.Container Then ' check treasure container
Wish.Index=False ' clear treasure found
Else ' check treasure
If TreasureRecord.Vehicle Then ' check treasure vehicle
Wish.Index=False ' clear treasure found
Else ' check treasure
Spell.Number=TreasureRecord.Spell ' get treasure spell
' check spell file bounds
If Spell.Number>False And _
Spell.Number<=Lof(SpellFile)/Len(SpellRecord) Then
Call Read.Record(SpellFile,Spell.Number) ' get spell record
If SpellRecord.SpellType=4 Then ' check spell type wish
Wish.Index=False ' clear treasure found
Endif ' end check wish spell
Endif ' end check spell file bounds
Endif ' end check treasure
Endif ' end check treasure
Endif ' end check normal player
Endif ' and check treasure found to drop
Endif ' end check drop type
Drop.Type=False ' clear drop flag
Select Case Wish.Index ' selection of item type to drop
Case Is<False ' check object being dropped
' add object to room
Call Add.Room.Object(Abs(Wish.Index),Wish.Charges,Drop.Type)
Case Is>False ' check treasure being dropped
Select Case TreasureRecord.Container ' selection of container dropped
Case False ' check treasure container
' add treasure to room
Call Add.Room.Treasure(Wish.Index,Wish.Charges,False,Drop.Type)
Case True ' check container
' check container name
If Rtrim$(RoomRecord.Container.ShortName)=Nul Then
Drop.Type=True ' set drop flag
' store container variables
ContainerRec.Closed=TreasureRecord.Closed
ContainerRec.ContainerName=TreasureRecord.TreasureName
ContainerRec.Locked=TreasureRecord.Locked
ContainerRec.Keyed=TreasureRecord.Keyed
ContainerRec.ShortName=TreasureRecord.ShortName
For Container.Count=1 To 5 ' loop through container contents
' clear container contents
Call Clear.Container(Container.Count,False)
Next ' end loop through container
RoomRecord.Container=ContainerRec ' add container record to room
Call Share.Room.Record(Room) ' write room record
Endif ' end check container
End Select ' end select container
End Select ' end select treasure
If Drop.Type=False Then ' check drop flag
Goto Wish.Denied ' jump to wish denied subroutine
Endif ' end check drop flag
Graphics.Off=True ' reset color
Outpt="A Dark Cloud Passes Overhead..." ' make ghod message
Call IO.O ' send message
Outpt=" Some Treasure Falls From The Sky..." ' make ghod message
Call IO.O ' send message
Outpt="The Cloud Disappears..." ' make ghod message
Call IO.O ' send message
Graphics.Off=False ' reset color
Exit Sub ' exit routine
Wish.Denied:
Graphics.Off=True ' reset color
Outpt="The Ghods Thunder..." ' make ghod message
Call IO.O ' send message
Outpt=" Your Wish Is Denied!" ' make ghod message
Call IO.O ' send message
Graphics.Off=False ' reset color
End Sub ' end routine to drop item to ground