-+-+-+-+-+-+-+-+ START OF PART 22 -+-+-+-+-+-+-+-+ X`5BASYNCHRONOUS`5D FUNCTION smg$end_pasteboard_update ( X`09pasteboard_id : UNSIGNED) : INTEGER; EXTERNAL; X`20 X`5BASYNCHRONOUS`5D FUNCTION smg$begin_pasteboard_update ( X`09pasteboard_id : UNSIGNED) : INTEGER; EXTERNAL; X X`5BASYNCHRONOUS`5D FUNCTION smg$put_chars ( X`09display_id : UNSIGNED; X`09text : `5BCLASS_S`5D PACKED ARRAY `5B$l2..$u2:INTEGER`5D OF CHAR; X`09start_row : INTEGER := %IMMED 0; X`09start_column : INTEGER := %IMMED 0; X`09flags : UNSIGNED := %IMMED 0; X`09rendition_set : UNSIGNED := %IMMED 0; X`09rendition_complement : UNSIGNED := %IMMED 0; X`09character_set : UNSIGNED := %IMMED 0) : INTEGER; EXTERNAL; X X`5BASYNCHRONOUS`5D FUNCTION smg$repaint_screen ( X`09pasteboard_id : UNSIGNED) : INTEGER; EXTERNAL; X X`5Basynchronous`5D Xprocedure wl(s:$udata := ''; echo:boolean := true); Xforward; X X`5Basynchronous`5D Xprocedure read_mailbox; Xforward; X Xfunction tpu$edit(%stdescr in_filename:strung; %stdescr out_filename:strung) V:unsigned; Xexternal; X X`5Basynchronous`5D Xfunction unmask(the_mask,looking_for:integer):boolean; Xbegin X if uand(the_mask,looking_for) = looking_for then unmask := true X else unmask := false; Xend; X X`5Basynchronous`5D Xfunction compress(a,b,c:integer := 0):integer; X`7BCompresses two signed integers +/-`5B0..999`5D or three positive integers V `5B0..999`5D`7D Xvar X count,signs:integer := 0; X temp:integer; X X procedure safe(var i:integer); X begin X if i < 0 then X begin X signs := signs + 2**count; X i := -i; X end; X if i > 999 then i := 999; X count := count + 1; X end; X Xbegin X safe(a); X safe(b); X safe(c); X temp := a * 1000000 + b * 1000 + c; X if c = 0 then temp := temp + 1000000000 + signs; X compress := temp; Xend; X X`5Basynchronous`5D Xprocedure decompress(n:integer; var a,b,c:integer); Xvar X signs,count:integer := 0; X signed:boolean := false; X `20 Xbegin X if n >= 1000000000 then X begin X n := n - 1000000000; X signed := true; X end; X a := n div 1000000; X b := n mod 1000000 div 1000; X c := n mod 1000; X X if signed then X begin X if c > 1 then X begin X c := c - 2; X b := -b; X end; X if c > 0 then a := -a; X end; Xend; X X`5Basynchronous`5D Xfunction int(i:integer):string; Xvar X s:string; Xbegin X writev(s,i:0); X int := s; Xend; X X`5Basynchronous`5D Xfunction boo(zok:boolean):char; Xbegin X if zok then boo := '+' X else boo := '-'; Xend; X X`5Basynchronous`5D Xprocedure bug_out(s:$udata); Xbegin X if debug then X begin X if human then wl('H> '+s) X else writeln(outfile,'M> '+s); X end; Xend; X X`5Basynchronous`5D Xfunction syscheck(s:$udata; fatal:boolean := false):boolean; Xbegin X if sysstatus <> 1 then X begin X writev(qpqp,'Error ',sysstatus:0,' in '); X bug_out(qpqp+s); X if fatal then X begin X if not human then close(outfile); X halt; X end; X end; X syscheck := (sysstatus = 1); Xend; X X`5Bhidden,external,asynchronous`5D Xprocedure ping(lognum:integer); Xexternal; X X`5Bhidden,external`5D Xfunction getkey(key_mode:integer := 0):char; Xexternal; X X`5Bhidden,external,asynchronous`5D Xprocedure handle_act; Xexternal; X Xprocedure disable_cursor; Xbegin X writeln(chr(27),'`5B?25l'); Xend; X Xprocedure enable_cursor; Xbegin X writeln(chr(27),'`5B?25h'); Xend; X X`5Basynchronous`5D Xprocedure disable_c; Xforward; X X`5Basynchronous`5D Xprocedure disable_y; Xforward; X X`5Basynchronous,unbound`5D Xprocedure handle_c(channel:integer); Xbegin X sysstatus := $cancel(channel); X wl('Whop!'); X disable_c; Xend; X X`5Basynchronous,unbound`5D Xprocedure handle_y(channel:integer); Xbegin X sysstatus := $cancel(channel); X if privlevel >= 10 then X begin X wl('One more time...'); X sysstatus := lib$enable_ctrl(save_dcl_ctrl); X end X else X begin X wl('Sorry, only privd people may ctrl-y out.'); X disable_y; X end; Xend; X Xprocedure disable_y; Xbegin X sysstatus := $qiow( X`09`09chan := tt_chan, X`09`09func := io$_setmode + io$m_ctrlyast, X`09`09iosb := io_status, X`09`09p1 := %immed handle_y, X`09`09p2 := %ref tt_chan); Xend; X Xprocedure disable_c; Xbegin X sysstatus := $qiow( X`09`09chan := tt_chan, X`09`09func := io$_setmode + io$m_ctrlcast, X`09`09iosb := io_status, X`09`09p1 := %immed handle_c, X`09`09p2 := %ref tt_chan); Xend; X X`5Basynchronous`5D Xfunction getticks:integer; Xvar X timevalue:`5Bunsafe, volatile`5D timetype; X secs:real; Xbegin X lib$stat_timer(1,timevalue,timercontext); X lib$cvtf_from_internal_time(lib$k_delta_seconds_f,secs,timevalue); X getticks:= trunc (10*secs); Xend; X X`5Bexternal,asynchronous`5D Xfunction mth$random(var seed:`5Bvolatile`5D integer):real; Xexternal; X X`5Basynchronous`5D Xfunction random:real; Xbegin X random := mth$random(seed); Xend; X X`5Basynchronous`5D Xfunction rnd:integer; Xbegin X rnd := round(mth$random(seed)*10000000); Xend; X X`5Basynchronous`5D Xfunction rnum(num:integer):integer; Xbegin X if num = 0 then rnum := 0 X else X begin X if num < 0 then rnum := - (1 + rnd mod abs(num)) X else rnum := 1 + rnd mod num; X end; Xend; X X`5Basynchronous`5D Xfunction bell(num:integer; cycles:integer := 3):integer; Xvar X i,sum:integer := 0; Xbegin X if cycles = 0 then cycles := 1; X if cycles > 50 then X begin X bug_out('Too many bell cycles'); X cycles := 50; X end; X for i := 1 to cycles do X sum := sum + rnum(num); X bell := sum div cycles; Xend; X X`5Basynchronous`5D Xfunction rnd100:integer; `7B random int between 0 & 100, maybe `7D Xbegin X rnd100 := round(mth$random(seed)*100); Xend; X Xfunction rdice(dice,num_dice:integer):integer; Xvar X i,sum:integer := 0; Xbegin X if num_dice <> 0 then X for i := 1 to num_dice do X sum := sum + rnd mod dice; X rdice := sum; Xend; X X`5Basynchronous`5D Xprocedure wait(seconds:real); Xbegin X sysstatus := lib$wait(seconds); Xend; X Xprocedure get_node(var node:lpack; var len:$uword); Xvar X list :array `5B1..2`5D of item_list_3; Xbegin X list`5B1`5D.buf_len := length(node); X list`5B1`5D.it_code := syi$_nodename; X list`5B1`5D.buf_adr := iaddress(node); X list`5B1`5D.len_adr := iaddress(len); X list`5B2`5D := zero; X sysstatus := $getsyi(,,,list,,,); Xend; X `20 Xfunction netpriv:boolean; Xvar X str:string; Xbegin X netpriv := false; X sysstatus := lib$getjpi(jpi$_curpriv,,,,%descr str); X if (index(str,'NETMBX')<>0) then netpriv := true; Xend; X Xprocedure get_logical(logical:mpack; var dev:`5Bvolatile`5D mpack); Xvar X str`09:string; X func`09:$uword; X list :array`5B1..2`5D of item_list_3; X len :unsigned; Xbegin X list`5B1`5D.buf_len := length(dev); X list`5B1`5D.it_code := lnm$_string; X list`5B1`5D.buf_adr := iaddress(dev); X list`5B1`5D.len_adr := iaddress(len); X list`5B2`5D := zero; X func := lnm$m_case_blind; X sysstatus := $trnlnm(func,'LNM$JOB',logical,,list); Xend; X X`5Basynchronous`5D Xprocedure act_out(send,act,x,y,p1,p2,p3,p4:integer := 0; X`09`09 msg,note:$udata := ''; X`09`09 allrooms:boolean := false; X`09`09 def_channel:$uword := 0); Xvar X i:integer; X func: $uword; X buf_len: integer; X mbx_data,debug_data:$udata; Xbegin X writev(mbx_data,send:0,' ',act:0,' ',x:0,' ',y:0,' ',p1:0,' ',p2:0,' ', X`09p3:0,' ',p4:0,' ',msg,chr(0),note,chr(1)); X func := io$_writevblk + io$m_norswait + io$m_now; X buf_len := length(mbx_data) + 2; X if (def_channel <> 0) then X begin X writev(debug_data,length(mbx_data):3,'O> `5B',def_channel:0,'`5D ',mbx_d Vata); X bug_out(debug_data); X sysstatus := $qiow(,def_channel,func,,,,%ref mbx_data, X`09`09%immed(buf_len),,,,); X if (sysstatus <> 1) then X begin X writev(qpqp,'Act out error ',sysstatus:0,' ',mbx_data); X bug_out(qpqp); X end; X end X else X begin X if not human then sysstatus := $qiow(,mychannel,func,,,,%ref mbx_data, X %immed(buf_len),,,,); X X for i := 1 to maxplayers do X if (person`5Bi`5D.here or allrooms) and X (indx`5Bi_ingame`5D.on`5Bi`5D) and`20 X (not indx`5Bi_npc`5D.on`5Bi`5D) then X begin X writev(debug_data,'O> `5B',i:0,'`5D ',mbx_data); X bug_out(debug_data); X sysstatus := $qiow(,person`5Bi`5D.channel,func,,,, X %ref mbx_data,%immed(buf_len),,,,); X if (sysstatus <> 1) then X begin X writev(debug_data,'Act out error ',sysstatus:0,' ',mbx_data); X bug_out(debug_data); X ping(i); X end; X end; X end; Xend; X X`5Basynchronous`5D Xprocedure set_mbx_ast; Xvar X io_status:iosb_type; Xbegin X sysstatus := $qiow( X`09`09chan := mychannel, X`09`09func := io$_setmode + io$m_wrtattn, X`09`09iosb := io_status, X`09`09p1 := %immed read_mailbox); X syscheck('set_mbx_ast'); Xend; X Xprocedure read_mailbox; Xvar X mbx_data,textline,debug_data:$udata; X io_status:iosb_type; X point,point1:integer; Xbegin X sysstatus := $qiow(chan := mychannel, X`09`09func := io$_readvblk + `7Bio$m_norswait + `7Dio$m_now, X`09`09iosb := io_status, X`09`09p1 := %ref mbx_data, X`09`09p2 := size(mbx_data)); X if length(mbx_data) > 0 then X begin X writev(debug_data,length(mbx_data):3,'I> '+mbx_data); X bug_out(debug_data); X with act do X readv(mbx_data,sender,action,xloc,yloc,parm1,parm2,parm3,parm4,textline) V; X point := index(textline,chr(0)); X point1:= index(textline,chr(1)); X act.msg := substr(textline,2,point-2); X act.note := substr(textline,point+1,point1-point-1); X handle_act; X end; X set_mbx_ast; Xend; X Xfunction create_mymbx(logical:mpack):boolean; Xvar X node:lpack; X len :$uword; Xbegin X create_mymbx := true; X sysstatus := $crembx(,mychannel,,4000,,,logical); X syscheck('create_mymbx',true); X get_logical(logical,mymbx); X get_node(node,len); X if (substr(node,1,len)<>game_node) then X begin X writeln('You must be on node '+game_node+' to run this program.'); X create_mymbx := false; X end; Xend; X X`5Basynchronous`5D Xfunction assign_channel(dev:mpack; var channel:`5Bvolatile`5D $uword):boolea Vn; Xbegin X sysstatus := $assign(dev,channel,,); X assign_channel := (sysstatus = 1); X syscheck('Assign channel to '+dev); Xend; X X`5Basynchronous`5D Xprocedure deassign_channel(channel:$uword); Xbegin X sysstatus := $dassgn(channel); X bug_out('Deassigned channel...'); X syscheck('Deassign channel'); Xend; X Xfunction get_userid:string; Xvar X uname:ident; Xbegin X sysstatus := lib$getjpi(jpi$_username,,,,uname); X get_userid := uname; Xend; X X`5Basynchronous`5D Xprocedure add_acl(f_name:string; aclstr:$udata); Xvar X aclent:string; X list :array `5B1..2`5D of item_list_3; X objtyp:$uword; X con`09:unsigned; Xbegin X sysstatus := $parse_acl(aclstr,%descr aclent,,); X list`5B1`5D.buf_len := size(aclent); X list`5B1`5D.it_code := acl$c_addaclent; X list`5B1`5D.buf_adr := iaddress(aclent); X list`5B1`5D.len_adr := 0; X list`5B2`5D := zero; X objtyp := acl$c_file; X con := 0; X sysstatus := $change_acl(,objtyp,f_name,list,,,con); Xend; X X`5Basynchronous`5D Xprocedure setprompt; Xbegin X smg$set_cursor_abs(twind,22,pos+1); Xend; X X`5Basynchronous`5D Xprocedure scroll_screen; Xbegin X smg$scroll_display_area(twind,1,1,21,78,smg$m_up); Xend; X X`5Basynchronous`5D Xprocedure wr(s:string := ''; echo:boolean := true); Xbegin X if echo and human then X begin X if wpos = 1 then scroll_screen; X smg$set_cursor_abs(twind,21,wpos); X smg$put_chars(twind,s); X wpos := wpos + length(s); X end; Xend; X Xprocedure wl`7B(s:$udata := ''; echo:boolean := true)`7D; Xvar X row:integer := 21; Xbegin X if echo and human then X begin X if length(s) > 78 then X begin X scroll_screen; X row :=20; X end; X if wpos = 1 then scroll_screen; X smg$set_cursor_abs(twind,row,wpos); X smg$put_line(twind,s,,,,smg$m_wrap_word); X setprompt; X wpos := 1; X end X else if debug and (not human) then bug_out(s); Xend; X Xfunction isnum(s:string):boolean; Xvar X i,temp:integer; X good:boolean; Xbegin X isnum := true; X if length(s) < 1 then isnum := false X else X begin X i := 1; X good := true; X while (i<= length(s)) and good do X if not (s`5Bi`5D in `5B'0'..'9','+','-'`5D) then good := false X else i := i + 1; X readv(s,temp,error := continue); X isnum := good and (statusv = 0); X end; Xend; X Xfunction number(s:string):integer; Xvar X i:integer; Xbegin X if (length(s) < 1) or not(s`5B1`5D in `5B'0'..'9','-','+'`5D) then number V := 0 X else X begin X readv(s,i, error := continue); X number := i; X end; Xend; X Xfunction keyget:$uword; Xvar X key:$uword := 0; X i:integer; Xbegin X sysstatus := smg$read_keystroke(keyboard,key,,1); X if sysstatus = 0 then keyget:= 0 X else keyget := key; Xend; X X`5Basynchronous`5D Xfunction new_prompt(prompt:string):string; Xbegin X if prompt <> '' then X begin X if prompt`5Blength(prompt)`5D in `5B'A'..'Z','a'..'z'`5D then X prompt := prompt + '? '; X if prompt`5Blength(prompt)`5D in `5B'0'..'9','?','>','!',':'`5D then X prompt := prompt + ' '; X end; X if prompt <> old_prompt then X begin X old_prompt := prompt; X smg$put_chars(twind,prompt,22,1,smg$m_erase_to_eol); X end; X new_prompt := prompt; Xend; X Xfunction grab_key(prompt:string := ''; keymode:integer := 0):char; Xbegin X prompt := new_prompt(prompt); X grab_key := getkey(keymode); Xend; X `20 Xprocedure grab_line(prompt:string := ''; X`09`09 var s:string; X`09`09 keymode:integer := 0; X`09`09 echo:boolean := true); Xvar X ch:char; X i:integer; Xbegin X prompt := new_prompt(prompt); X line := ''; X pos := length(prompt); X ch := getkey(keymode); X while (ch <> chr(13)) and (ch <> chr(26)) do X begin X if (ch = chr(8)) or (ch = chr(127)) then X begin `7B del char `7D X case length(line) of X`090:ch := getkey(keymode); X`091:begin X`09 line := ''; X`09 if echo then smg$delete_chars(twind,1,22,pos); X`09 pos := pos - 1; X`09 ch := getkey(keymode); +-+-+-+-+-+-+-+- END OF PART 22 +-+-+-+-+-+-+-+-