-+-+-+-+-+-+-+-+ START OF PART 40 -+-+-+-+-+-+-+-+ X`09`09 curse := curse`5E.next; X`09 until ((flag) or (curse = nil)); X`09 if (not(flag)) then X`09 begin X`09 curse := inventory_list; X`09`09while (curse`5E.next <> nil) do X `09`09 curse := curse`5E.next; X`09 curse`5E.next := new_item; X`09`09add_inven_item := new_item; X`09`09inven_ctr := inven_ctr + 1; X`09 inven_weight := inven_weight + wgt; X`09 end; X`09 end; X end; X X`09`7B Add the item in INVEN_MAX to players inventory. Return the`09`7D X`09`7B item position for a description if needed...`09`09-RAK-`09`7D X`5Bglobal,psect(inven$code)`5D function inven_carry : treas_ptr; X begin X`09inven_carry := add_inven_item(inven_temp`5E.data); X end; X X X`09`7B Drop money onto ground`09`09`09`09-DMF-`09`7D X function drop_money(var ptr : treas_ptr; var clr : boolean) : boolean; X`09var X`09`09out_val`09`09: vtype; X`09`09out_val2`09: vtype; X`09`09flag`09`09: boolean; X`09`09test_flag`09: boolean; X`09`09command`09`09: char; X`09`09com_val`09`09: integer; X`09`09reset_flag`09: boolean; X`09`09max`09`09: integer; X`09`09mon_name`09: vtype; X`09`09amt`09`09: integer; X`09`09pos`09`09: integer; X`09`09mon_type`09: integer; X begin X drop_money := false; X ptr := nil; X clr := false; X if (cave`5Bchar_row,char_col`5D.tptr > 0) then X`09begin X`09 msg_print('There is something there already.'); X`09 clr := true; X`09end X else X with py.misc do begin X`09com_val := get_money_type('Drop ',reset_flag,false); X`09reset_flag := not(reset_flag); X`09if not(reset_flag) then X`09 begin X`09 case com_val of X`09 109 : mon_name := 'mithril'; X`09 112 : mon_name := 'platinum'; X`09 103 : mon_name := 'gold'; X`09 115 : mon_name := 'silver'; X`09 99 : mon_name := 'copper'; X`09 105 : mon_name := 'iron'; X`09 end; X`09 out_val := 'Drop how much ' + mon_name + ' (1-'; X`09 coin_stuff(chr(com_val),mon_type); X`09 max := money`5Bmon_type`5D; X`09 writev(out_val2,max:1); X`09 out_val := out_val + out_val2 + '), `5EZ to exit : '; X`09 prt(out_val,1,1); X`09 if (get_string(out_val2,1,length(out_val)+1,10)) then X`09 begin X`09`09readv(out_val2,amt,error:=continue); X`09`09if (amt > max) then amt := max; X`09`09if (amt < 1) then X`09`09 begin X`09`09 msg_print('You don''t have that much money.'); X`09`09 clr := true; X`09`09 end X`09`09else X`09`09 begin X`09`09 money`5Bmon_type`5D := money`5Bmon_type`5D - amt; X`09`09 case mon_type of X`09`09`091 : pos := iron_pos; X`09`09`092 : pos := copper_pos; X`09`09`093 : pos := silver_pos; X`09`09`094 : pos := gold_pos; X`09`09`095 : pos := platinum_pos; X`09`09`096 : pos := mithril_pos; X`09`09 end; X`09`09 inven_temp`5E.data := gold_list`5Bpos`5D; X`09`09 inven_temp`5E.data.number := amt; X`09`09 ptr := inven_temp; X`09`09 drop_money := true; X`09`09 inven_weight := inven_weight - coin$weight * amt; X`09`09 reset_total_cash; X`09`09 prt_gold; X`09`09 end; X`09 end X`09 else X`09 erase_line(msg_line,msg_line); X`09 end; X end; X end; X X`09`7B Get the ID of an item and return the CTR value of it`09-RAK-`09`7D X `5Bglobal,psect(inven$code)`5D function get_item( X`09`09`09var com_ptr`09: treas_ptr; X`09`09`09pmt`09`09: vtype; X`09`09`09var redraw`09: boolean; X`09`09`09count`09`09: integer; X`09`09`09var choice`09: char; X`09`09`09mon`09`09: boolean; X`09`09`09no_wait`09`09: boolean := false) : boolean; X var X`09 command : char; X`09 out_val : vtype; X`09 test_flag : boolean; X`09 i1`09`09`09`09`09`09: integer; X`09 stay`09`09`09`09`09`09: boolean; X`09 only_money `09`09`09`09`09: boolean; X X begin X`09only_money := false; X`09stay := false; X`09get_item := false; X`09if (count < 1) then only_money := true; X`09com_val := 0; X`09 begin X`09 if (mon) then X`09 if (count > 20) then X`09`09writev(out_val,'(Items a-t,$, for inventory, `5EZ to exit) ', X`09`09`09`09pmt) X`09 else if (not only_money) then X`09`09writev(out_val,'(Items a-',chr(count+96), X`09`09`09 ',$, for inventory list, `5EZ to exit) ',pmt) X`09 else X`09`09writev(out_val,' ') X`09 else X `09 if (count > 20) then X`09 writev(out_val,'(Items a-t, for inventory, `5EZ to exit) V ',pmt) X `09 else X`09 writev(out_val,'(Items a-',chr(count+96), X`09`09`09 ', for inventory list, `5EZ to exit) ',pmt); X`09 test_flag := false; X`09 if (not(no_wait)) then prt(out_val,1,1); X`09 repeat X`09 if (only_money) then X`09`09command := '$' X`09 else X`09 begin`20 X`09 if (not(no_wait)) then X`09`09 inkey(command) X`09 else X`09`09 command := '*'; X`09 end; X`09 choice := command; X`09 com_val := ord(command); X`09 case com_val of X`09`090,3,25,26,27 : begin X`09`09`09`09 test_flag := true; X`09`09`09`09 reset_flag := true; X`09`09`09`09end; X`09`0942, 32 : begin X`09`09`09`09 clear(2,1); X`09`09`09`09 writev(out_val,'(Items a-%N, for next page, `5EZ to ex Vit) ',pmt); X`09`09`09`09 get_item := inven_command('?',com_ptr,out_val); X`09`09`09`09 test_flag := true; X`09`09`09`09 redraw := true; X`09`09`09`09end; X`09`0936 :`09`09if (mon) then begin X`09`09`09`09 test_flag := true; X`09`09`09`09 redraw := false; X`09`09`09`09 with py.misc do X`09`09`09`09 if (money`5B1`5D+money`5B2`5D+money`5B3`5D+money`5B4`5D+ X`09`09`09money`5B5`5D+money`5B6`5D > 0) then X`09`09`09`09`09get_item := drop_money(com_ptr,stay) X`09`09`09`09 else X`09`09`09`09 begin X`09`09`09`09`09msg_print('You have no money to drop.'); X`09`09`09`09`09get_item := false; X`09`09`09`09`09stay := true; X`09`09`09`09 end; X`09`09`09`09end; X`09`0949,50,51,52,53,54,55,56,57: X`09`09begin X`09`09 test_flag := true; X`09`09 prt(chr(com_val),1,length(out_val)+2); X`09`09 inkey(choice); X`09`09 prt(choice,1,length(out_val)+3); X`09`09 if ((choice <= 't') and (choice >= 'a')) then X`09`09 begin X`09`09 com_ptr := inventory_list; X`09`09 count := 0; X`09`09 if (not ((com_ptr`5E.next=nil)or(count>=(com_val-49)*20+ord(choice)- V97))) then X`09`09 repeat X`09`09 if ((not(com_ptr`5E.is_in)) and (uand(com_ptr`5E.data.flags2,holding V_bit) = 0)) then count := count + 1; X`09`09 com_ptr := com_ptr`5E.next; X`09`09 until ((com_ptr`5E.next = nil)or(count = (com_val-49)*20+ord(choice) V-97)); X`09`09 if ((com_ptr`5E.next = nil) and (count<>(com_val-49)*20+ord(choice)- V97)) then X`09`09 begin X`09`09 get_item := false; X`09`09 stay := true; X`09`09 prt('Invalid Selection.',1,1); X`09`09 end X`09`09 else X`09`09 get_item := true; X`09`09 end; X`09`09end; X`09`09otherwise begin X`09`09`09`09 com_val := com_val - 96; X`09`09`09`09 if ((com_val >= 1) and X`09`09`09`09 (com_val <= count) and X`09`09`09`09 (com_val <= 20)) then X`09`09`09`09 begin X`09`09`09`09 com_ptr := inventory_list; X`09`09`09`09 i1 := 1; X`09`09`09`09 while (com_ptr`5E.ok = false) do X`09`09`09`09`09com_ptr := com_ptr`5E.next; X`09`09`09`09 while (i1 <> com_val) do X`09`09`09`09`09begin X`09`09`09`09`09 if (com_ptr`5E.ok) then X`09`09`09`09`09 i1 := i1 + 1; X`09`09`09`09`09 com_ptr := com_ptr`5E.next; X`09`09`09`09`09 while (com_ptr`5E.ok = false) do X`09`09`09`09`09 com_ptr := com_ptr`5E.next; X`09`09`09`09`09end; X`09`09`09`09 test_flag := true; X`09`09`09`09 get_item := true; X`09`09`09`09 end; X`09`09`09`09end; X`09 end; X`09 until (test_flag); X`09 if not(stay) then erase_line(msg_line,msg_line); X`09 end; X end; Xend. X X $ CALL UNPACK INVEN.PAS;1 772680121 $ create 'f' X`5BInherit('Moria.Env')`5D Module IO; X X`09`7B Convert an integer into a system bin time`09`09-RAK-`09`7D X`09`7B NOTE: Int_time is number of 1/100 seconds`09`09`09`7D X`09`7B`09Max value = 5999`09`09`09`09`09`7D X`5Bglobal,psect(misc2$code)`5D procedure convert_time( X`09`09 int_time`09: unsigned; X`09`09var bin_time`09: quad_type); X type X`09time_type = packed array `5B1..13`5D of char; X var X`09time_str`09: time_type; X`09secs,tics`09: unsigned; X`09out_val`09`09: varying`5B2`5D of char; X X `5Basynchronous,external(SYS$BINTIM)`5D function $bin_time( X`09`09%stdescr`09give_str`09: time_type; X`09`09var`09`09slp_time`09: quad_type X`09`09`09`09`09`09) : integer; X`09external; X X begin X time_str := '0 00:00:00.00'; X bin_time.l0 := 0; X bin_time.l1 := 0; X tics := int_time mod 100; X secs := int_time div 100; X if (secs > 0) then X`09begin X`09 if (secs > 59) then secs := 59; X`09 writev(out_val,secs:2); X`09 time_str`5B10`5D := out_val`5B2`5D; X`09 if (secs > 9) then time_str`5B9`5D := out_val`5B1`5D; X`09end; X if (tics > 0) then X`09begin X`09 writev(out_val,tics:2); X`09 time_str`5B13`5D := out_val`5B2`5D; X`09 if (tics > 9) then time_str`5B12`5D := out_val`5B1`5D; X`09end; X $bin_time(time_str,bin_time); X end; X X X`09`7B Set timer for hibernation`09`09`09`09-RAK-`09`7D X `5Basynchronous,external(SYS$SETIMR)`5D function set_time( X`09%immed efn`09: integer := %immed 5; X`09var bintime`09: quad_type; X`09%ref astadr`09: integer := %immed 0; X`09%immed reqidt`09: integer := %immed 0) : integer; X`09external; X X X`09`7B Hibernate `09`09`09`09`09`09-RAK-`09`7D X `5Basynchronous,external(SYS$WAITFR)`5D function hibernate( X`09%immed efn`09: integer := %immed 5) : integer; X`09external; X X X`09`7B Sleep for given time`09`09`09`09`09-RAK-`09`7D X`09`7B NOTE: Int_time is in seconds`09`09`09`09`09`7D X`5Bglobal,psect(misc2$code)`5D procedure sleep(int_time : unsigned); X var X`09bin_time`09: quad_type; X begin X convert_time(int_time*100,bin_time); X set_time(bintime:=bin_time); X hibernate; X end; X X`09`7B Sleep for short time`09`09`09`09`09-DMF-`09`7D X`5Bglobal,psect(misc2$code)`5D procedure mini_sleep(int_time : unsigned); X var X`09bin_time`09: quad_type; X begin X convert_time(int_time,bin_time); X set_time(bintime:=bin_time); X hibernate; X end; X X X`09`7B Turns SYSPRV off if 0; on if 1;`09`09`09-RAK-`09`7D X`09`7B This is needed if image is installed with SYSPRV because`09`7D X`09`7B user could write on system areas. By turning the priv off`09`7D X`09`7B system areas are secure`09`09`09`09`09`7D X`5Bglobal,psect(setup$code)`5D procedure priv_switch(switch_val : integer); X type X`09priv_field=`09record`09`7B Quad word needed for priv mask`7D X`09`09`09 low`09: unsigned; X`09`09`09 high`09: unsigned; X`09`09`09end; X var X`09priv_mask`09: priv_field; X X`09`7B Turn off SYSPRV`09`09`09`09`09-RAK-`09`7D X `5Bexternal(SYS$SETPRV)`5D function $setprv( X`09%immed enbflg`09: integer := %immed 0; X`09var privs`09: priv_field; X`09%immed prmflg`09: integer := %immed 0; X`09%immed prvprv`09: integer := %immed 0) : integer; X`09external; X X begin X priv_mask.low := %X'10000000';`09`7B SYSPRV`09`7D X priv_mask.high := %X'00000000'; X $setprv(enbflg:=switch_val,privs:=priv_mask); X end; X X X`09`7B Turn off Control-Y`09`09`09`09`09-RAK-`09`7D X`5Bglobal,psect(setup$code)`5D procedure no_controly; X var X`09bit_mask`09: unsigned; X X `5Bexternal(LIB$DISABLE_CTRL)`5D function y_off( X`09var mask`09: unsigned; X`09 old_mask`09: integer := %immed 0) : integer; X`09external; X X begin X bit_mask := %X'02000000';`09`7B No Control-Y`09`7D X y_off(mask:=bit_mask); X end; X X X`09`7B Turn on Control-Y`09`09`09`09`09-RAK-`09`7D X`5Bglobal,psect(setup$code)`5D procedure controly; X var X`09bit_mask`09: unsigned; X X `5Bexternal(LIB$ENABLE_CTRL)`5D function y_on( X`09var mask`09: unsigned; X`09 old_mask`09: integer := %immed 0) : integer; X`09external; X X begin X bit_mask := %X'02000000';`09`7B Control-Y`09`7D X y_on(mask:=bit_mask); X end; X X X`5Bglobal,psect(setup$code)`5D procedure exit; X X`09`7B Immediate exit from program`09`09`09`09`09`7D X `5Bexternal(SYS$EXIT)`5D function $exit( X`09%immed status`09: integer := %immed 1) : integer; X`09external; X X begin X`09controly;`09`7B Turn control-Y back on`09`7D X`09put_qio;`09`7B Dump any remaining buffer`09`7D X`09$exit;`09`09`7B exit from game`09`09`7D X end; X X X`09`7B Initializes I/O channel for use with INKEY`09`09`09`7D X`5Bglobal,psect(setup$code)`5D procedure init_channel; X type X ttype = packed array `5B1..3`5D of char; X var X status`09`09: integer; X terminal`09`09: ttype; X X `5Bexternal(SYS$ASSIGN)`5D function assign( X`09%stdescr terminal`09: ttype; X`09var channel`09`09: `5Bvolatile`5D integer; X`09acmode`09`09`09: integer := %immed 0; X`09mbxnam`09 `09`09: integer := %immed 0) : integer;`20 X`09external; X X begin X terminal := 'TT:'; X status := assign(terminal,channel); X if (not odd(status)) then X begin X`09 writeln('Channel could not be assigned '); X`09 exit; X end X end; X X X`09`7B QIOW definition`09`09`09`09`09-RAK-`09`7D X `5Basynchronous,external(SYS$QIOW)`5D function qiow_read( X`09%immed efn`09`09: integer := %immed 1; X`09%immed chan `09`09: integer; X`09%immed func`09`09: integer := %immed 0; X`09%immed isob`09`09: integer := %immed 0; X`09%immed astadr`09`09: integer := %immed 0; X`09%immed astprm`09`09: integer := %immed 0; X`09%ref get_char`09`09: `5Bunsafe`5D char := %immed 0; X`09%immed buff_len`09`09: integer := %immed 0; X`09%immed delay_time`09: integer := %immed 0; X`09%immed p4`09`09: integer := %immed 0; X`09%immed p5`09`09: integer := %immed 0; X`09%immed p6`09`09: integer := %immed 0) : integer; X`09external; X X`09`7B Gets single character from keyboard and returns`09`09`7D X`5Bglobal,psect(io$code)`5D procedure inkey(var getchar : char); X var X`09status`09`09`09: integer; X begin X put_qio;`09`09`09`7B Dump IO buffer`09`09`7D X`09`7B Allow device driver to catch up`09`09`09`7D X`09`7B NOTE: Remove or comment out for VMS 4.0 or greater`09`7D X`7B X set_time(bintime:=IO$BIN_PAUSE); X hibernate; X`7D +-+-+-+-+-+-+-+- END OF PART 40 +-+-+-+-+-+-+-+-