-+-+-+-+-+-+-+-+ START OF PART 18 -+-+-+-+-+-+-+-+ X recj = record X unameinfo : packed record X unamelen : word; X jpi$_username : word; X END; X ptr_uname : `5Eusernam; X ptr_unamelen : `5Einteger; X endlist : integer X END; X usernam = packed array `5B1..12`5D of char; X`20 X`20 X`7B function returns the players USERNAME `7D X function get_username : usernam; X var X user : usernam; X icode : integer; X jpirec : recj; X`20 X`7B calls GETJPI routine to return the USERNAME `7D X function sys$getjpi (%immed p1 : integer; X %immed p2 : integer; X %immed p3 : integer; X var itmlst : recj; X %immed p4 : integer; X %immed p5 : integer; X %immed p6 : integer) : integer; X external; X`20 X BEGIN X with jpirec do X BEGIN X unameinfo.unamelen := 12; X unameinfo.jpi$_username := %x202; X new (ptr_uname); X ptr_uname`5E := ' '; X new (ptr_unamelen); X ptr_unamelen`5E := 0; X endlist := 0 X END; X icode := SYS$GETJPI (0,0,0,jpirec,0,0,0); X if not odd(icode) then X BEGIN X writeln('Error in GETJPI process'); X halt X END X else X get_username := jpirec.ptr_uname`5E X END; X `20 X`20 X`7B Centers a string within a 31 character string `7D X function fill_str (p1 : vtype) : vtype; X var X s1 : vtype; X i1 : integer; X BEGIN X s1 := ''; X i1 := trunc(length(p1) / 2); X fill_str := substr(pad(s1,' ',15-i1) + pad(p1,' ',31),1,31); X END; X`20 X`20 X`7B Prints a line to the screen efficiently `7D X procedure dprint(str : vtype; row : integer); X var X i1,i2,nblanks,xpos : integer; X prt_str : vtype; X BEGIN X prt_str := ''; X nblanks := 0; X xpos := 0; X for i1 := 1 to length(str) do X BEGIN X if (str`5Bi1`5D = ' ') then X BEGIN X if (xpos > 0) then X BEGIN X nblanks := nblanks + 1; X if (nblanks > 5) then X BEGIN X nblanks := 0; X put_buffer(prt_str,row,xpos); X prt_str := ''; X xpos := 0; X END X END; X END X else X BEGIN X if (xpos = 0) then xpos := i1; X if (nblanks > 0) then X BEGIN X for i2 := 1 to nblanks do X prt_str := prt_str + ' '; X nblanks := 0; X END; X prt_str := prt_str + str`5Bi1`5D; X END; X END; X if (xpos > 0) then X put_buffer(prt_str,row,xpos); X END; X`20 X`20 X`7B Prints the gravestone of the character `7D X procedure print_tomb; X var X str1,str2,str3,str4,str5,str6,str7,str8 : vtype; X dstr : array `5B0..19`5D of vtype; X fnam : vtype; X command : char; X f1 : text; X i1 : integer; X day : packed array `5B1..11`5D of char; X flag : boolean; X BEGIN X date(day); X str1 := fill_str(py.misc.name); X str2 := fill_str(py.misc.title); X str3 := fill_str(py.misc.tclass); X writev(str4,'Level : ',py.misc.lev:1); X str4 := fill_str(str4); X writev(str5,py.misc.exp:1,' Exp'); X str5 := fill_str(str5); X writev(str6,py.misc.au:1,' Au'); X str6 := fill_str(str6); X writev(str7,'Died on Level : ',dun_level:1); X str7 := fill_str(str7); X str8 := fill_str(died_from); Xdstr`5B00`5D := ' '; Xdstr`5B01`5D := ' _______________________'; Xdstr`5B02`5D := ' / \ ___'; Xdstr`5B03`5D := ' / \ ___ / \ _ V__'; Xdstr`5B04`5D := ' / RIP \ \ : : / V \'; Xdstr`5B05`5D := ' / \ : _;,,,;_ : V :'; Xdstr`5B06`5D := ' /'+str1+ '\,;_ _;, V,,;_'; Xdstr`5B07`5D := ' `7C the `7C ___'; Xdstr`5B08`5D := ' `7C '+str2+ ' `7C / \'; Xdstr`5B09`5D := ' `7C `7C : :'; Xdstr`5B10`5D := ' `7C '+str3+ ' `7C _;,,,;_ V ____'; Xdstr`5B11`5D := ' `7C '+str4+ ' `7C / V \'; Xdstr`5B12`5D := ' `7C '+str5+ ' `7C : V :'; Xdstr`5B13`5D := ' `7C '+str6+ ' `7C : V :'; Xdstr`5B14`5D := ' `7C '+str7+ ' `7C _; V,,,,;_'; Xdstr`5B15`5D := ' `7C killed by `7C'; Xdstr`5B16`5D := ' `7C '+str8+ ' `7C'; Xdstr`5B17`5D := ' `7C '+day+ ' `7C'; Xdstr`5B18`5D := ' *`7C * * * * * * `7C *'; Xdstr`5B19`5D := '________)/\\_)_/___(\/___(//_\)/_\//__\\(/_`7C_)_______'; X clear(1,1); X for i1 := 0 to 19 do X dprint(dstr`5Bi1`5D,i1+1); X flush; X if (get_com('Print to file? (Y/N)',command)) then X case command of X 'y','Y': BEGIN X prt('Enter Filename:',1,1); X flag := false; X repeat X if (get_string(fnam,1,17,60)) then X BEGIN X if (length(fnam) = 0) then fnam:='MORIACHR.DIE V'; X open (f1,file_name:=fnam,error:=continue); X if (status(f1) <> 0) then X prt('Error creating> ' + fnam,2,1) X else X BEGIN X flag := true; X rewrite(f1,error:=continue); X for i1 := 0 to 19 do X writeln(f1,dstr`5Bi1`5D,error:=continue) V; X END; X close(f1,error:=continue); X END X else X flag := true; X until(flag) X END; X otherwise X END X END; X`20 X`20 X`7B Calculates the total number of points earned `7D X function total_points : integer; X BEGIN X with py.misc do X total_points := max_exp + (100*py.misc.max_lev); X END; X`20 X`20 X`7B Enters a players name on the top forty list `7D X procedure top_forty; X var X list : array `5B1..20`5D of vtype; X blank : packed array `5B1..13`5D of char; X i1,i2,i3,i4,n1,mwk5,trys : integer; X o1,o2 : vtype; X f1 : text; X flag,file_flag : boolean; X BEGIN X if (wizard) then exit; X clear(1,1); X for i1 := 1 to 20 do X list`5Bi1`5D := ''; X n1 := 1; X priv_switch(1); X trys := 0; X file_flag := false; X repeat X open (f1,file_name:=moria_top, X organization:=sequential,history:=old, X sharing:=none,error:=continue); X if (status(f1) = 2) then X BEGIN X trys := trys + 1; X if (trys > 5) then X file_flag := true X else X sleep(2); X END X else X file_flag := true; X until(file_flag); X if ((status(f1) <> 0) and (status(f1) <> 2)) then X open (f1,file_name:=moria_top, X organization:=sequential,history:=new, X sharing:=none,error:=continue); X if (status(f1) <> 0) then X BEGIN X writeln('Error in opening ',moria_top); X writeln('Please contact local Moria Wizard.'); X exit; X END; X reset(f1); X while ((not eof(f1)) and (n1 <= 20)) do X BEGIN X readln(f1,list`5Bn1`5D,error:=continue); X n1 := n1 + 1; X END; X n1 := n1 - 1; `20 X i1 := 1; X i3 := total_points; X flag := false; X while ((i1 <= n1) and (not flag)) do X BEGIN X readv(list`5Bi1`5D,blank,i4); X if (i4 < i3) then X flag := true X else X i1 := i1 + 1; X END; X if ((flag) or (n1 = 0) or (n1 < 20)) then X BEGIN X for i2 := 19 downto i1 do X list`5Bi2+1`5D := list`5Bi2`5D; X o1 := get_username; X case py.misc.lev of X 1 : writev(o2,py.misc.lev:1,'st level '); X 2 : writev(o2,py.misc.lev:1,'nd level '); X 3 : writev(o2,py.misc.lev:1,'rd level '); X otherwise writev(o2,py.misc.lev:1,'th level ') X END; X writev(list`5Bi1`5D,pad(o1,' ',13),i3:7,' ', X py.misc.name,', a ',o2,py.misc.race,' ', X py.misc.tclass,'.'); X if (n1 < 20) then X n1 := n1 + 1; X flag := false; X END; X rewrite(f1); X for i1 := 1 to n1 do X writeln(f1,list`5Bi1`5D); X close(f1); `20 X priv_switch(0); X writeln('Username Points Character that died.'); X for i1 := 1 to n1 do X BEGIN X writeln(list`5Bi1`5D); X mwk5:=i1 X END; X mwk5:=mwk5+2; X writeln; X put_qio X END; X`20 X`20 X`7B Change the player into a King! `7D X procedure kingly; X BEGIN X`7B Change the character attributes.`7D X dun_level := 0; X died_from := 'Ripe Old Age'; X with py.misc do X BEGIN X lev := lev + max_player_level; X if (sex`5B1`5D = 'M') then X BEGIN X title := 'Magnificent'; X tclass := '*King*' X END X else X BEGIN X title := 'Beautiful'; X tclass := '*Queen*' X END; X au := au + 250000; X max_exp := max_exp + 5000000; X exp := max_exp X END; X`7B Let the player know that he did good.`7D X clear(1,1); X dprint(' #',2); X dprint(' #####',3); X dprint(' #',4); X dprint(' ,,, $$$ ,,,',5); X dprint(' ,,=$ "$$$$$" $=,,',6); X dprint(' ,$$ $$$ $$,',7); X dprint(' *> <*> <*',8); X dprint(' $$ $$$ $$',9); X dprint(' "$$ $$$ $$"',10); X dprint(' "$$ $$$ $$"',11); X dprint(' *#########*#########*',12); X dprint(' *#########*#########*',13); X dprint(' Veni, Vidi, Vici!',16); X dprint(' I came, I saw, I conquered!',17); X dprint(' All Hail the Mighty King!',18); X flush; X pause(24); X END; X`20 X`20 X`7B What happens upon dying...`7D X BEGIN X if (total_winner) then kingly; X print_tomb; X top_forty; X exit X END; X `20 $ CALL UNPACK [.SOURCE.INCLUDE]DEATH.INC;1 69466317 $ create 'f' X`7B Object descriptor routines`20 X Randomize colors, woods, and metals `7D X`5Bpsect(setup$code)`5D procedure randes; X var X i1,i2 : integer; X tmp : vtype; X BEGIN X for i1 := 1 to max_colors do X BEGIN X i2 := randint(max_colors); X tmp := colors`5Bi1`5D; X colors`5Bi1`5D := colors`5Bi2`5D; X colors`5Bi2`5D := tmp; X END; X for i1 := 1 to max_woods do X BEGIN X i2 := randint(max_woods); X tmp := woods`5Bi1`5D; X woods`5Bi1`5D := woods`5Bi2`5D; X woods`5Bi2`5D := tmp; X END; X for i1 := 1 to max_metals do X BEGIN X i2 := randint(max_metals); X tmp := metals`5Bi1`5D; X metals`5Bi1`5D := metals`5Bi2`5D; X metals`5Bi2`5D := tmp; X END; X for i1 := 1 to max_rocks do X BEGIN X i2 := randint(max_rocks); X tmp := rocks`5Bi1`5D; X rocks`5Bi1`5D := rocks`5Bi2`5D; X rocks`5Bi2`5D := tmp; X END; X for i1 := 1 to max_amulets do X BEGIN X i2 := randint(max_amulets); X tmp := amulets`5Bi1`5D; X amulets`5Bi1`5D := amulets`5Bi2`5D; X amulets`5Bi2`5D := tmp; X END; X for i1 := 1 to max_mush do X BEGIN X i2 := randint(max_mush); X tmp := mushrooms`5Bi1`5D; X mushrooms`5Bi1`5D := mushrooms`5Bi2`5D; X mushrooms`5Bi2`5D := tmp; X END; X END; X`20 X`20 X`7B Return random title `7D X`5Bpsect(setup$code)`5D procedure rantitle ( var title : varying`5Ba`5D of V char ); X var X i1,i2,i3 : integer; X BEGIN X i3 := randint(2) + 1; X title := 'Titled "'; X for i1 := 1 to i3 do X BEGIN X for i2 := 1 to randint(2) do X title := title + syllables`5Brandint(max_syllables)`5D; X if (i1 <> i3) then title := title + ' '; X END; X title := title + '"'; X END; X`20 X`20 X`7B Initialize all Potions, wands, staves, scrolls, ect..`7D +-+-+-+-+-+-+-+- END OF PART 18 +-+-+-+-+-+-+-+-