-;COPYRIGHT (C) 1980 BY
-;ROY TRUBSHAW, RICHARD BARTLE & BRIAN MALLETT,\r
-;ESSEX UNIVERSITY, COLCHESTER. CO4 3SQ.\r
+;Copyright (C) 1980 by\r
+;Roy Trubshaw, Richard Bartle & Brian Mallett,\r
+;Essex University, Colchester. CO4 3SQ.\r
;\r
-; THIS SOFTWARE IS FURNISHED ON THE UNDERSTANDING THAT\r
-;IT MAY BE USED AND OR COPIED ONLY WITH THE INCLUSION OF THIS\r
-;NOTICE. NO TITLE OR OWNERSHIP OF THIS SOFTWARE IS HEREBY\r
-;TRANSFERRED. THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO\r
-;CHANGE WITHOUT NOTICE. NO RESPONSIBILITY IS ASSUMED FOR THE\r
-;USE OR RELIABILITY OF THIS SOFTWARE.\r
+; This software is furnished on the understanding that\r
+;it may be used and or copied only with the inclusion of this\r
+;notice. No title or ownership of this software is hereby\r
+;transferred. The information in this software is subject to\r
+;change without notice. No responsibility is assumed for the\r
+;use or reliability of this software.\r
\r
- TITLE BCPL\r
- TWOSEG 400K\r
+ TITLE BCPL\r
+ TWOSEG 400K\r
\r
- SEARCH UUOSYM\r
+ SEARCH UUOSYM\r
+\r
+ CODE1==617022\r
+ CODE2==13731\r
+ CODE3==26262\r
\r
- JRST .BCPL.## ; CATCH FALL THROUGH\r
-..BCPL::TDZA 1, 1\r
- SETO 1, 0 ; SET UP CCL VALUE\r
- MOVEM 1, %CCL## ;STORE IT.\r
- MOVEM 0, %CALLNM## ;SAVE NAME OF THIS GAME...\r
- CAIN .SGPPN, 75 ;FRIG FOR 7.001 MONITOR - GET 75 INSTEAD OF PPN\r
- MOVE .SGPPN, 77 ;REAL PPN IS IN 77 (PART OF LOOKUP BLOCK)\r
- MOVEM .SGPPN, MAINTA## ;SAVE AS MAINTAINER'S PPN\r
- MOVEM .SGPPN, PATHPP ;SAVE FOR ASSIGNING MUD:\r
- CAIN .SGDEV, 75 ;SAME PALAVER FOR DEVICE NOW\r
- MOVE .SGDEV, 75 ;DEVICE IS 1ST ENTRY IN LOOKUP BLOCK\r
- SKIPN .SGDEV ;DID HE GIVE A DISC?\r
- MOVEI .SGDEV, 'DSK' ;NO SO ASSUME DSK...\r
- MOVEM .SGDEV, DISC ;STOW AWAY...\r
- MOVEM .SGDEV, PATHDV ;...AGAIN.\r
- CAME .SGDEV, [ SIXBIT /DSK/ ]\r
- CAMN .SGDEV, [ SIXBIT /ALL/ ]\r
- JRST PAST\r
- CAMN .SGDEV, [ SIXBIT /LIB/ ]\r
- JRST PAST\r
- MOVEI 2, 4\r
-LOP: MOVE 1, [ XWD 3, LOC]\r
- JOBSTR 1,\r
- JRST PAST\r
- MOVE 1, LOC\r
- JUMPE 1, OVER\r
- CAMN 1, ADDR+1\r
- JRST PAST\r
- MOVEM 1, ADDR(2)\r
- ADDI 2, 3\r
- JRST LOP\r
-OVER: SOS 2\r
- HRLI 1, @2\r
- HRRI 1, ADDR\r
- STRUUO 1,\r
- TRN\r
-PAST: HRRI 1, PATHBK\r
- HRLI 1, 12\r
- PATH. 1,\r
- TRN\r
- RESET\r
- SETZ 1,\r
- SETUWP 1,\r
- HALT\r
-\r
-\r
-\r
-\r
-\r
-\r
- SKIPE 74\r
- JRST [ OUTSTR [ ASCIZ /\r
-IF YOU THINK I'LL LET YOU DDT ME YOU'VE ANOTHER THINK COMING, SQUIRE...\r
-/ ]\r
- JRST @.\r
- EXIT\r
- ]\r
- MOVEI 1,VEC\r
- PIINI. 1,0\r
- TRN\r
- MOVEI 1,SWINT\r
- MOVEM 1,VEC+4\r
- MOVE 1,[ PS.FON+PS.FAC+ARGS]\r
- PISYS. 1,0\r
- TRN\r
- MOVEI 1, 2\r
- HRLI 1, 3\r
- MOVEI 2, 2036\r
- SETO 3,\r
- TRMNO. 3,\r
- TRN\r
- SETZ 4,\r
- TRMOP. 1,\r
- TRN\r
- MOVEI 2, 2003\r
- TRMOP. 1,\r
- TRN\r
- MOVEI 2, 2005\r
- SETO 4,\r
- TRMOP. 1,\r
- TRN\r
- JRST 400010 ;START RIPPLE THROUGH\r
-SWINT: DMOVEM 1, SUMADD\r
- MOVEM 3, SUMADD+2 ;WHAT'S WRONG WITH PUSHING ON STACK?\r
- HRRZ 1,STATUS ;PASSED VALUE\r
- HLRZ 2,STATUS ;JOB NUMBER\r
- HLL 3,STATUS\r
- HRRI 3,2 ;TABLE 2 GETS PPN FOR JOB\r
- GETTAB 3,\r
- JRST WALLY\r
- CAME 3,MAINTA## ;MAKE SURE MAINTAINER DID IT\r
- JRST WALLY\r
- SUB 1,2\r
- CAIN 1,"N"\r
- JRST NICE\r
- CAIN 1,"H"\r
- JRST HORRIB\r
-WALLY: DMOVE 1, SUMADD\r
- MOVE 3, SUMADD+2\r
- DEBRK.\r
- HALT\r
-HORRIB: OUTSTR [ASCIZ /\r
-SOMETHING MAGICAL HAS HAPPENED NASTILY...\r
+ JRST .BCPL.## ; CATCH FALL THROUGH\r
+..BCPL::TDZA 1, 1\r
+ SETO 1, 0 ; SET UP CCL VALUE\r
+ MOVEM 1, %CCL## ;Store it.\r
+ MOVEM 0, %CALLNM## ;Save name of this game...\r
+ CAIN .SGPPN, 75 ;Frig for 7.001 monitor - get 75 instead of ppn\r
+ MOVE .SGPPN, 77 ;Real ppn is in 77 (part of lookup block)\r
+ MOVEM .SGPPN, MAINTA## ;Save as maintainer's ppn\r
+ MOVEM .SGPPN, PATHPP ;Save for assigning MUD:\r
+ CAIN .SGDEV, 75 ;Same palaver for device now\r
+ MOVE .SGDEV, 75 ;Device is 1st entry in lookup block\r
+ SKIPN .SGDEV ;Did he give a disc?\r
+ MOVEI .SGDEV, 'DSK' ;No so assume dsk...\r
+ MOVEM .SGDEV, DISC ;stow away...\r
+ MOVEM .SGDEV, PATHDV ;...again.\r
+ came .sgdev, [ sixbit /dsk/ ]\r
+ camn .sgdev, [ sixbit /all/ ]\r
+ jrst past\r
+ camn .sgdev, [ sixbit /lib/ ]\r
+ jrst past\r
+ movei 2, 4\r
+lop: move 1, [ xwd 3, loc]\r
+ jobstr 1,\r
+ jrst past\r
+ move 1, loc\r
+ jumpe 1, over\r
+ camn 1, addr+1\r
+ jrst past\r
+ movem 1, addr(2)\r
+ addi 2, 3\r
+ jrst lop\r
+over: sos 2\r
+ hrli 1, @2\r
+ hrri 1, addr\r
+ struuo 1,\r
+ trn\r
+past: hrri 1, pathbk\r
+ hrli 1, 12\r
+ path. 1,\r
+ trn\r
+ RESET\r
+ setz 1,\r
+ setuwp 1,\r
+ halt\r
+ SKIPE 74\r
+ JRST [ OUTSTR [ ASCIZ /\r
+If you think I'll let you DDT me you've another think coming, squire...\r
+/ ]\r
+ JRST @.\r
+ EXIT\r
+ ]\r
+ movei 1, imrtrp\r
+ movem 1, .jbapr\r
+ movei 1, ap.pov+ap.ilm+ap.nxm+ap.par\r
+ aprenb 1, 0\r
+ moveI 1,vec\r
+ piini. 1,0\r
+ trn\r
+ movei 1,swint\r
+ movem 1,vec+4\r
+ movei 1,imrtrp\r
+ movem 1,vec+10\r
+ move 1,[ ps.fon+ps.fac+args]\r
+ pisys. 1,0\r
+ trn\r
+ move 1,[ ps.fon+ps.fac+args1]\r
+ pisys. 1,0\r
+ trn\r
+ skipn esxwd##\r
+ jrst ripple\r
+ movei 1, 2\r
+ hrli 1, 3\r
+ movei 2, 2036\r
+ seto 3,\r
+ trmno. 3,\r
+ trn\r
+ setz 4,\r
+ trmop. 1,\r
+ trn\r
+ movei 2, 2003\r
+ trmop. 1,\r
+ trn\r
+ripple: JRST 400010 ;Start ripple through\r
+swint: movem 1, sumadd\r
+ hrrz 1, status\r
+ cain 1, code1\r
+ jrst cone\r
+ caie 1, code2\r
+ cain 1, code3\r
+ jrst ctwo\r
+wally: setzm half\r
+okok: move 1, sumadd\r
+ debrk.\r
+ halt\r
+cone: setom half\r
+ jrst okok\r
+ctwo: skipn half\r
+ jrst wally\r
+ caie 1, code2\r
+ jrst nice\r
+ skipe maint##\r
+ jrst [ outstr [asciz /\r
+Someone has just tried to do something magical to you nastily.\r
+/ ]\r
+ jrst wally\r
+ ]\r
+ outstr [asciz /\r
+Someone has done something magical to you, nastily...\r
/ ]\r
- EXIT\r
- HALT\r
-NICE: OUTSTR [ASCIZ /\r
-SOMETHING MAGICAL HAS HAPPENED NICELY...\r
+ exit\r
+ halt\r
+nice: outstr [asciz /\r
+Someone has done something magical to you, nicely...\r
+/]\r
+ setom ctcflg##\r
+ jrst wally\r
+\r
+imrtrp: movei 1, imrext\r
+ movem 1, .jbapr\r
+ outstr [asciz /\r
+Something amazingly magical has happened!\r
/]\r
- SETOM CTCFLG##\r
+ skipe magic##\r
+ jrst imrext\r
+ setom magic##\r
+ jsp 14, @resetgame##\r
+ subi 16, 2\r
+imrext: exit 1,\r
+ \r
+reloc\r
+ \r
+sumadd: block 1\r
+half: 0\r
+vec: block 4\r
+new: 0\r
+old: 0\r
+flags: 0\r
+status: 0\r
+new1: 0\r
+old1: 0\r
+flags1: 0\r
+stats1: 0\r
+ \r
+args: .pcjbi\r
+ xwd 4,0\r
+ xwd 2,0\r
+args1: .pciuu\r
+ xwd 10,0\r
+ xwd 2,0\r
+ \r
+pathbk: -5\r
+ 0\r
+ sixbit /MUD/\r
+ 0\r
+pathdv: exp 0, 0, 0\r
+pathpp: exp 0, 0, 0, 0\r
+addr: .fssrc\r
+disc:: block 1\r
+ 0\r
+ 0\r
+ block ^d21 ;should be enough for most searchlists...\r
+loc: exp -1,0,0\r
+ END ..BCPL\r
+\r
+\r
+\r
+\r
+\\\\\\r
+\fSUBFILE: POWER.BCL @11:29 13-NOV-1986 <477> (3816) \r
+/*\r
+Copyright (C) 1980 by\r
+Roy Trubshaw & Richard Bartle,\r
+Essex University, Colchester. CO4 3SQ.\r
+\r
+ This software is furnished on the understanding that\r
+it may be used and or copied only with the inclusion of this\r
+notice. No title or ownership of this software is hereby\r
+transferred. The information in this software is subject to\r
+change without notice. No responsibility is assumed for the\r
+use or reliability of this software.\r
+*/\r
+\r
+get "bcl:acs"\r
+get "bcl:scb"\r
+get "bcl:iolib"\r
+get "dungen"\r
+get "bcl:rfslib"\r
+\r
+$LDTEXT "/RUNAME:power"\r
+\r
+external "."\r
+$( fn\r
+$)\r
+\r
+manifest\r
+$( TREESIZE = RECLENGTH+2\r
+ RIGHT = RH | TREESIZE-1\r
+ LEFT = LH | TREESIZE-1\r
+ CHAIN = RH | TREESIZE\r
+ PPPN = #2011002011//MPPN\r
+$)\r
+\r
+static\r
+$( lastblock = 0\r
+ cbl = vec 1\r
+ dmpbuf = vec BUFFERS\r
+ cbll = vec 1\r
+ perputt = ?\r
+ dmpbuff = vec BUFFERS\r
+ bcntt = 1\r
+ nextrec = ?\r
+ game = $6"mud"\r
+ rock = $6"rock"\r
+ blud = $6"blud"\r
+ perput = ?\r
+ rec = ?\r
+ gender = 0\r
+ me = 0\r
+ ch = ?\r
+ name = vec 1\r
+ room = 0\r
+ tree = 0\r
+$)\r
+\r
+let start() be\r
+$( let bcnt=1\r
+ output:=tty\r
+ outs("The power program!*C*L")\r
+ $[ $rescan\r
+zonk: $inchrs 1\r
+ $jrst plonk\r
+ $caie 1, '-'\r
+ $jrst zonk\r
+cronk: $inchrs 1\r
+ $jrst plonk\r
+ $trz 1, #40\r
+ $caie 1, 'M'\r
+ $cain 1, 'V'\r
+ $jrst wonk\r
+ $caie 1, 'B' //spot the hacks...\r
+ $cain 1, 'R'\r
+ $trna\r
+ $jrst cronk\r
+ $move 2, rock\r
+ $cain 1, 'B'\r
+ $move 2, blud\r
+ $movem 2, game\r
+wonk: $inchrs 1\r
+ $trna\r
+ $jrst wonk\r
+plonk: $]\r
+ input:=tty\r
+ Readname(name, "Password: ")\r
+ test !name=!"bushbaby" then outs("*C*LThat'll do...*C*L") or\r
+ $( Outs("*C*LEek! Go away!*C*L")\r
+ finish\r
+ $)\r
+ $( Outs("Frig, Start, League, Transfer, Enumerate, Password, Dot, Reveal, Mud, Kill*C*Lor One-off? ")\r
+ switchon valof\r
+ $[ $clrbfi\r
+ $inchrw 1\r
+ $trz 1, #40\r
+ $] into\r
+ $(\r
+ case 'R': outs("eveal*C*L")\r
+ reveal()\r
+ finish\r
+ case 'M': outs("ud*C*L")\r
+ run($6"dsk", $6"mud", $6"exe", PPPN)\r
+ case 'S': outs("tart*C*L")\r
+ strat()\r
+ finish\r
+ case 'D': outs("ot*C*L")\r
+ dot()\r
+ finish\r
+ case 'F': outs("rig*C*L")\r
+ break\r
+ case 'L': outs("eague*C*L")\r
+ league()\r
+ finish\r
+ case 'T': outs("ransfer*C*L")\r
+ Transfer()\r
+ finish\r
+ case 'E': outs("numerate*C*L")\r
+ Enumerate()\r
+ finish\r
+ case 'P': outs("assword*C*L")\r
+ password()\r
+ finish\r
+ case 'K': outs("ill*C*L")\r
+ kill()\r
+ finish\r
+ case 'O': outs("ne-off*C*L")\r
+ oneoff()\r
+ finish\r
+ default 0 ... #137:\r
+ Outs("*C*LEh?*C*L")\r
+ $)\r
+ $) repeat\r
+ setup()\r
+ readname(name, "Name: ")\r
+ if !name =!"richard" Outs("*C*LYou're so naive...*C*L")<>finish\r
+ searchrec(name)\r
+ if rec then rec_rec rem 128+dmpbuf\r
+ test rec then\r
+ $( let sc, sx=SCRE of rec, WRD1 of rec bitand 1\r
+ outs("Current character profile is:*C*L")\r
+ out("Name*T*T:s:s*C*Lscore*T*T:n*T:s*C*Lstrength*T:n*C*L",rec+2,WIZD of rec bitand WIZMASK -> "*TWIZ","",sc,lev(sc,sx),STRN of rec)\r
+ out("dexterity*T:n*C*Lstamina*T*T:n*T(max*T:n)*C*Lgames played*T:n*C*Lsex*T*T:smale*C*Lp/w*T:8*C*L",\r
+ dxty of rec,stna of rec,stmx of rec,games of rec, sx -> "fe", "",PSWD of rec)\r
+ dumpersona(true)\r
+ save.block()\r
+ $) or\r
+ $( out("No current persona! I'll make one for you, :s.*C*L",name)\r
+ addrec(name)\r
+ rec_rec rem 128+dmpbuf\r
+ games of rec_1\r
+ WRD1 of rec_!name\r
+ WRD2 of rec_LENGTH of name>4 -> 1!name,0\r
+ WIZD of rec_false\r
+ dumpersona()\r
+ save.block()\r
+ $)\r
+ Close(perput)\r
+ deq(sc.channel^perput)\r
+$)\r
+and dumpersona(pw) be\r
+$( unless numbargs() pw_false\r
+ if pw pw_ESSEX\r
+ if pw pw_appendfile($6"dsk",$6"prolog",$6"prl", MPPN,label(oops))\r
+ if pw\r
+ $( write(pw,"POWERing :S*C*LStr.*TDex.*TSta.*TScore*TSex*TP/w*C*L",name)\r
+ write(pw,":N*T:N*T:N*T:N*T:S*T:8*C*L",STRN of rec,DXTY of rec,\r
+ STMX of rec,SCRE of rec,((WRD1 of rec) bitand 1)->"f","m",PSWD of rec)\r
+ $)\r
+ outs("Prepare to fulfill your wildest dreams!*C*L")\r
+ outs("Strength ?"); STRN of rec_getno(STRN)\r
+ outs("Stamina (max) ?"); STNA of rec_getno(STMX); STMX of rec_STNA of rec\r
+ outs("Dexterity ?"); DXTY of rec_getno(DXTY)\r
+ outs("Score ?"); SCRE of rec_getno(SCRE)\r
+ outs("Sex ?")\r
+ $[ $CLRBFI\r
+ $INCHRW ch\r
+ $]\r
+ Gender_(WRD1 of rec) bitand 1\r
+ TEST ch='M'\/ch='m' THEN OUTS("ale*C*L")<>gender_0\r
+ OR if ch= 'F'\/ch='f' THEN OUTS("emale*C*L")<>\r
+ gender_1\r
+ outs("Pn ?"); PN of rec_Getno(PN,true)\r
+ unless PN of rec PN of rec_valof $[ $getppn 1, 0 $]\r
+ WRD1 of rec_((WRD1 of rec) bitand ~1) bitor gender\r
+ LSTM of rec_valof\r
+ $[ $hrri ac, #11\r
+ $hrli ac, #53\r
+ $gettab ac, 0\r
+ $trn\r
+ $]\r
+ if pw /\ (PSWD of rec ne 0)\r
+ $( outs("Zero p/w ?")\r
+ if valof\r
+ $[ $clrbfi\r
+ $inchrw 1\r
+ $trz 1, #40\r
+ $caie 1, 'Y'\r
+ $jrst render\r
+ $outstr $az"es*C*L"\r
+ $trna\r
+render: $setz 1, 0\r
+ $clrbfi\r
+ $] then PSWD of rec_0\r
+ $)\r
+ if pw\r
+ $( write(pw,":N*T:N*T:N*T:N*T:S*T:8*C*L",STRN of rec,DXTY of rec,\r
+ STMX of rec,SCRE of rec,((WRD1 of rec) bitand 1)->"f","m",PSWD of rec)\r
+ close(pw)\r
+ $)\r
+ return\r
+oops: Outs("*C*LI can't log this frig, so I won't do it, sorry.*C*L")\r
+$)\r
+and load.block(stream,block) be\r
+$( if block=lastblock return\r
+ useti(perput,block)\r
+ inuuo(stream,cbl)\r
+ lastblock_block\r
+$)\r
+and save.block(block) be\r
+$( let blk=numbargs()->block,lastblock\r
+ useto(perput,blk)\r
+ outuuo(perput,cbl)\r
+$)\r
+and searchrec(nam) = valof\r
+$( let pnt,lrec,str=?,0,vec 1\r
+ !str_!nam\r
+ 1!str_LENGTH of nam>4 -> 1!nam, 0\r
+ load.block(perput,1)\r
+ lrec_hashval(str)\r
+ rec_dmpbuf!lrec\r
+ while rec\r
+ $( load.block(perput,rec/WDSPERBUF+1)\r
+ pnt_(rec rem WDSPERBUF)+dmpbuf\r
+ if namesame(str,2+pnt) break\r
+ lrec_rec\r
+ rec_POINTR of pnt\r
+ $)\r
+ resultis lrec\r
+$)\r
+and saverec(nam) = valof\r
+$( searchrec(nam)\r
+ unless rec addrec(nam)\r
+ if rec //In case addrec hasn't added them.\r
+ $( load.block(perput,rec/WDSPERBUF+1)\r
+ dumpersona(rec rem WDSPERBUF+dmpbuf)\r
+ save.block()\r
+ $)\r
+ resultis rec //return a value to indicate whether you've been saved.\r
+$)\r
+and deleterec(nam) be\r
+$( let olrec,odel,lrec=?,?,searchrec(nam)\r
+ and pnt=rec rem WDSPERBUF+dmpbuf\r
+ unless rec return //Can't find record\r
+ //Ok, this may look a little long-winded\r
+ load.block(perput,rec/WDSPERBUF+1) //but it's worth it not to corrupt the persona file in case of a crash\r
+ WRD1 of pnt_0\r
+ WRD2 of pnt_0 //Zero names for purges etc.\r
+ GAMES of pnt_0 //Yawn thinks we need this, too! (WE DO! - Yawn xx)\r
+ olrec_!pnt\r
+ save.block()\r
+\r
+ load.block(perput,lrec/WDSPERBUF+1)\r
+ dmpbuf!(lrec rem WDSPERBUF)_olrec //Old pointer to rec now points to old pointer of rec.\r
+ save.block()\r
+ \r
+ load.block(perput,1) //Get the deleted record pointer\r
+ odel_DEL of dmpbuf\r
+ save.block()\r
+\r
+ load.block(perput,rec/WDSPERBUF+1) //And plonk it in the record to be deleted\r
+ !pnt_odel //Does anyone read all these comments?\r
+ save.block()\r
+\r
+ load.block(perput,1) //Finally update the deleted record pointer to point to the newly deleted record!\r
+ DEL of dmpbuf_rec\r
+ save.block()\r
+$)\r
+and addrec(nam) be\r
+$( let hashcont,olrec,str=?,?,vec 1\r
+ !str_!nam\r
+ 1!str_LENGTH of nam>4 -> 1!nam,0\r
+ load.block(perput,1)\r
+ rec_DEL of dmpbuf\r
+ test rec then\r
+ $( load.block(perput,rec/WDSPERBUF+1)\r
+ olrec_POINTR of (rec rem WDSPERBUF+dmpbuf)\r
+ save.block()\r
+ $) or\r
+ $( rec_FLEN of dmpbuf\r
+ unless rec //No persona file exists.\r
+ $( rec_2*WDSPERBUF\r
+ FLEN of dmpbuf_rec //Create hash table\r
+ $)\r
+ olrec_0 //No deleted records\r
+ FLEN of dmpbuf+_RECLENGTH\r
+ save.block()\r
+ $)\r
+ load.block(perput,1)\r
+ DEL of dmpbuf_olrec\r
+ hashcont_dmpbuf!hashval(str)\r
+ dmpbuf!hashval(str)_rec\r
+ save.block()\r
+\r
+ load.block(perput,rec/WDSPERBUF+1)\r
+ POINTR of (dmpbuf+rec rem WDSPERBUF)_hashcont\r
+ save.block()\r
+$)\r
+and hashval(nam) = ((!nam+1!nam)>>1) rem 253\r
+and kill() be\r
+$( setup()\r
+ readname(name, "Name: ")\r
+ if !name =!"richard" Outs("*C*LNot Richard...*C*L")<>finish\r
+ deleterec(name)\r
+ test rec then out(":s terminated.",name)\r
+ or out(":s already dead - you can only kill people once!",name)\r
+ \r
+ Close(perput)\r
+ deq(sc.channel^perput)\r
+$)\r
+and getno(sel,octal)=valof\r
+$( let ch=valof\r
+ $[ $clrbfi\r
+ $inchrw 1\r
+ $]\r
+ unless numbargs()=2 octal_false\r
+ unless '0' le ch le '9'\r
+ $( $[ $clrbfi $]\r
+ resultis sel of rec\r
+ $)\r
+ putback(input, ch)\r
+ ch_(octal->inoct,inno)()\r
+ $( let stk=SC.PUTSTACK^input\r
+ SC.PUTSTACK^input, SC.READER^input _ !stk, stk!2\r
+ freevec(stk)\r
+ $)\r
+ resultis ch\r
+$)\r
+and inoct(nopb)=valof\r
+$( let res=0 and ch=?\r
+ ch_inch() repeatuntil '0' le ch le '7'\r
+ while '0' le ch le '7' do\r
+ $( res_(res<<3)-'0'+ch\r
+ ch_inch()\r
+ $)\r
+ unless numbargs() putback(input,ch)\r
+ resultis res\r
+$)\r
+and readname(nm, pr) be\r
+$( let n,ch,linev=0,?,vec NAMELENGTH\r
+ write(tty, pr)\r
+ readch(input,@ch)\r
+ while 'a'<=(ch bitor #40)<='z' do\r
+ $( n+:1\r
+ unless n>NAMELENGTH linev!n:='A'<=ch<='Z'->ch+#40,ch\r
+ readch(input,@ch)\r
+ $)\r
+ !linev:=n>NAMELENGTH->NAMELENGTH,n\r
+ packstring(linev,nm)\r
+ until ch='*L' do readch(input,@ch)\r
+$) repeatuntil LENGTH of nm\r
+and dot() be\r
+$( let stfl,no,ch=0,?,?\r
+ writes(tty,"Please enter the job number of the about to be dotted job*C*L(0 for all of them)*C*L")\r
+ writes(tty,"**")\r
+ no_rdno(tty)\r
+ $( let res=?\r
+ writes(tty,"dotted nicely or horribly N/H? ")\r
+ $[ $clrbfi\r
+ $inchrw ch\r
+ $]\r
+ stfl_0\r
+ test ch='H' \/ ch='h' then stfl_#13731<>writes(tty,"orribly*C*L") or\r
+ if ch='N' \/ ch='n' then stfl_#26262<>writes(tty,"icely*C*L")\r
+ unless stfl writes(tty,"*Binvalid character*C*L")<>loop\r
+ for i=1 to 200 dispose(#617022,i)\r
+ test no then res_dispose(stfl, no)\r
+ or for i=1 to 200 if dispose(stfl, i) res_true\r
+ unless res Writes(tty, "*C*L?POWIDW - it didn't work so stop pissing around.*C*L")\r
+ finish \r
+ $) repeat\r
+$)\r
+and dispose(stfl, no) be\r
+$[ $hrrz 2,stfl\r
+ $hrl 2,no\r
+ $calli 2,#175\r
+ $setz 1,0 //uh?\r
+$]\r
+and namesame(nam1,nam2)=\r
+(!nam1>>1)=(!nam2>>1)/\((LENGTH of nam1<=4)\/(1!nam1>>1)=(1!nam2>>1))\r
+and strat() be\r
+$( let resp=?\r
+ $( writes(tty, "*C*LMud, Valley or Rock? ")\r
+ $[ $inchrw 1\r
+ $trz 1, ' '\r
+ $movem 1, resp\r
+ $]\r
+ $) repeatuntil resp='V' | resp='M' | resp='R'\r
+ write(tty, ":s*C*L", resp='R'->"ock", resp='V'->"alley", "ud")\r
+ resp_resp='R' -> $6"rock",resp='V'->$6"valley", $6 "mud"\r
+ output_createtmp(resp)\r
+ readname(name, "Name: ")\r
+ writes(tty, "*C*LRoom: ")\r
+ $[ $clrbfi $]\r
+ for i=0 to 5 do\r
+ $( let letter = byte 6:30-6*i\r
+ and next = valof $[ $inchrw 1 $]\r
+ if 'a' le next le 'z' next-_'a'-'A'\r
+ if next = '*C' break\r
+ letter from room _ next-' '\r
+ $)\r
+ $[ $clrbfi $]\r
+ out(":s*^C:n*$:n*$:n", name,\r
+ valof $[ $mstime 1, 0 $],\r
+ valof $[ $mstime 1, 0 $],\r
+ room)\r
+ close(output)\r
+ run($6 "dsk", resp, $6 "exe", 0)\r
+$)\r
+\r
+and setup() be\r
+$( !cbl_(-BUFFERS<<18)bitor(dmpbuf-1)\r
+ 1!cbl_0\r
+ if false\r
+ $(\r
+dogoneit: perput_createfile($6"dsk",game,$6".pm",PPPN,0,#17,1)\r
+ enq(SC.CHANNEL^perput)\r
+ useto(perput,2)\r
+ outuuo(perput,cbl)\r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+ $)\r
+ perput_updatefile($6"dsk",game,".pm",PPPN,label(dogoneit),#17,1)\r
+ enq(sc.channel^perput)\r
+ useti(perput,1)\r
+$)\r
+and reveal() be\r
+$( let ch, f, fil, ext=?, ?, vec 1, vec 1\r
+ readname(fil, "File part: ")\r
+ readname(ext, "Extension part: ")\r
+ f_findfile($6"dsk", fil, ext, 0, label(absent))\r
+ if false\r
+absent: f_findfile($6"dsk", fil, ext, PPPN, label(nowhere))\r
+ input_f\r
+ ch_Inch()\r
+ while ch ne '*E'\r
+ $( outch(ch)\r
+ ch_inch()\r
+ $)\r
+ close(f)\r
+ input_tty\r
+ return\r
+nowhere: out("Sorry, I can't find :S.:S*C*L", fil, ext)\r
+$)\r
+\r
+and password() be\r
+$( let num,numrecs,bcnt=?,?,3\r
+ setup()\r
+ out("*C*LOctal password: ")\r
+ num_inoct(true)\r
+ \r
+ useti(perput,1)\r
+ inuuo(perput,cbl)\r
+ numrecs_(FLEN of dmpbuf-256)/12 //First find the number of records\r
+\r
+ useti(perput,bcnt) //Load in the first block of records\r
+ inuuo(perput,cbl)\r
+\r
+ rec_dmpbuf\r
+ for i=1 to numrecs\r
+ $( if WRD1 of rec /\ num=PSWD of rec\r
+ out(":S on :N points*C*L", rec+2, SCRE of rec)\r
+ if (rec-dmpbuf)>128\r
+ $( rec -_ 128\r
+ bcnt +_ 1\r
+ useti(perput,bcnt)\r
+ inuuo(perput,cbl)\r
+ $) \r
+ rec+_RECLENGTH\r
+ $)\r
+\r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+$)\r
\r
+and Lev(pts, fem)=valof\r
+$( let sc=exp.step\r
+ for i=0 to 9\r
+ $( if sc ge pts resultis i\r
+ sc+_sc\r
+ $)\r
+ resultis 9\r
+$)!(fem!(table\r
+ (table "novice",\r
+ "warrior",\r
+ "hero",\r
+ "champion",\r
+ "superhero",\r
+ "enchanter",\r
+ "sorcerer",\r
+ "necromancer",\r
+ "legend",\r
+ "wizard"\r
+ ),\r
+ (table "novice",\r
+ "warrior",\r
+ "heroine",\r
+ "champion",\r
+ "superheroine",\r
+ "enchantress",\r
+ "sorceress",\r
+ "necromancess",\r
+ "legend",\r
+ "witch"\r
+ )\r
+ )\r
+)\r
\r
+and Enq(chan) be\r
+$( let addr=vec 4\r
+ !addr_#1000005\r
+ 1!addr_142857\r
+ 2!addr_chan\r
+ 3!addr_$az"mud"+(-1<<18)\r
+ 4!addr_0\r
+ Out("*C*LENQ. error code :8*C*L", valof\r
+ $[ $move 1, addr\r
+ $enq. 1, 0\r
+ $trna\r
+ $( return $)\r
+ $])\r
+$)\r
\r
+and Deq(chan) be\r
+$( let addr=vec 1\r
+ !addr_#1000005\r
+ 1!addr_142857\r
+ Out("*C*LDEQ.error code :8*C*L", valof\r
+ $[ $move 1, addr\r
+ $hrli 1, 1\r
+ $deq. 1, 0\r
+ $trna\r
+ $( return $)\r
+ $])\r
+$)\r
+and transfer() be\r
+$( let peep, bcnt, numrecs=?, 3, ?\r
+ outs("where from? (0 for everywhere) ")\r
+ peep_inoct(true)\r
+ setup()\r
+ \r
+ useti(perput,1)\r
+ inuuo(perput,cbl)\r
+ numrecs_(FLEN of dmpbuf-256)/12 //First find the number of records\r
\r
+ useti(perput,bcnt) //Load in the first block of records\r
+ inuuo(perput,cbl)\r
\r
+ rec_dmpbuf\r
+ for i=1 to numrecs\r
+ $( if WRD1 of rec /\ (PN of rec=peep | peep=0)\r
+ $( out(":s: [**,:8] -> ", rec+2, PN of rec)\r
+ PN of rec_Getno(PN, true)\r
+ $)\r
+ \r
+ if (rec-dmpbuf)>128\r
+ $( rec -_ 128\r
+ useto(perput, bcnt)\r
+ outuuo(perput, cbl)\r
+ bcnt +_ 1\r
+ useti(perput,bcnt)\r
+ inuuo(perput,cbl)\r
+ $)\r
+ rec+_RECLENGTH\r
+ $)\r
\r
- JRST WALLY\r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+$)\r
+\r
+and League() be\r
+$( let numrecs,bcnt=?,3\r
+ setup()\r
+ useti(perput,1)\r
+ inuuo(perput,cbl)\r
+ numrecs_(FLEN of dmpbuf-256)/12 //First find the number of records\r
+\r
+ useti(perput,bcnt) //Load in the first block of records\r
+ inuuo(perput,cbl)\r
+\r
+ rec_dmpbuf\r
+ for i=1 to numrecs\r
+ $( if WRD1 of rec tree_insert(SCRE of rec, tree)\r
+ if (rec-dmpbuf)>128\r
+ $( rec -_ 128\r
+ bcnt +_ 1\r
+ useti(perput,bcnt)\r
+ inuuo(perput,cbl)\r
+ $) \r
+ rec+_RECLENGTH\r
+ $)\r
+\r
+\r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+ outs("Writing to LEAGUE.ENM")\r
+ output_createfile("dsk","league","enm",0)\r
+ outree(tree)\r
+ while me\r
+ $( let p=LH of me\r
+ Out("richard*T*T[**,:8]:c*T34359738369*T9999*Tyes*TWIZARD*C*L",p, p ls #1000->'*T','*0')\r
+ me of_RH\r
+ $)\r
+ close(output)\r
+$)\r
+and today()=valof\r
+$[ $hrli 1, #53\r
+ $hrri 1, #11\r
+ $gettab 1, 0\r
+ $trn\r
+ $hlrz 1, 1\r
+$]\r
+and Enumerate() be\r
+$( let now,bcnt,numrecs=today(),3,?\r
+ setup()\r
+ outs("Writing to POWER.ENM*C*L")\r
+ output_Createfile($6"dsk",$6"power",$6"enm", 0, Label(rats))\r
+ outs("Enumeration of personas as of ")\r
+ outtime()\r
+ outs(" on ")\r
+ outdate()\r
+ outs(":*C*L*L")\r
+ \r
+ useti(perput,1)\r
+ inuuo(perput,cbl)\r
+ numrecs_(FLEN of dmpbuf-256)/12 //First find the number of records\r
+\r
+ useti(perput,bcnt) //Load in the first block of records\r
+ inuuo(perput,cbl)\r
+\r
+ rec_dmpbuf\r
+ for i=1 to numrecs\r
+ $( if WRD1 of rec\r
+ $( let t, sx, wz=now-(LH from LSTM of rec), (WRD1 of rec) bitand 1, WIZD of rec\r
+ Out("Name:*T*T:S*C*LPpn:*T*T[**,:8]*C*LScore:*T*T:N*C*LStrength:*T:N*C*LDexterity:*T:N*C*LStamina:*T:N*Tmax :N*C*L",\r
+ rec+2,PN of rec,SCRE of rec,STRN of rec,DXTY of rec,STNA of rec,STMX of rec)\r
+ Out("Last game:*T:N day:S ago*C*Lgames:*T*T:N*C*Lsex:*T*T:Smale*C*L",\r
+ t,t=1->"","s",GAMES of rec,sx->"fe","")\r
+ if wz bitand WIZMASK Out("Mode:*T*TWI:S*C*L", sx->"TCH","ZARD")\r
+ if wz bitand 4 Outs("Mode:*T*TBERSERK*C*L")\r
+ Outs("*C*L*L")\r
+ $)\r
+ if (rec-dmpbuf)>128\r
+ $( rec -_ 128\r
+ bcnt +_ 1\r
+ useti(perput,bcnt)\r
+ inuuo(perput,cbl)\r
+ $) \r
+ rec+_RECLENGTH\r
+ $)\r
+\r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+ close(output)\r
+ Writes(tty,"*C*LEnumerated in DSK:POWER.ENM*C*L")\r
+ if false\r
+rats: Writes(tty,"*C*LCan't create DSK:POWER.ENM*C*L")\r
+$)\r
+\r
+and insert(sc, tree)=valof\r
+$( if tree test sc ls SCRE of tree then\r
+ $( LEFT of tree_insert(sc, LEFT of tree)\r
+ resultis tree\r
+ $) or if sc gr SCRE of tree then\r
+ $( RIGHT of tree_insert(sc, RIGHT of tree)\r
+ resultis tree\r
+ $)\r
+ sc_Newvec(TREESIZE)\r
+ for i=0 to RECLENGTH sc!i_rec!i\r
+ sc!(RH from RIGHT)_0\r
+ if tree\r
+ $( CHAIN of sc_CHAIN of tree\r
+ CHAIN of tree_sc\r
+ resultis tree\r
+ $)\r
+ CHAIN of sc_0\r
+ resultis sc\r
+$)\r
+\r
+and outree(tree) be if tree\r
+$( let l, r, n, p=LEFT of tree, RIGHT of tree, tree+2, PN of tree\r
+ outree(l)\r
+ test !n=!"richard" then\r
+ $( let m=newvec(0)\r
+ LH of m_p\r
+ RH of m_me\r
+ me_m\r
+ $) or\r
+ Out(":s:c*T[**,:8]:c*T:N*T:c:N*T:8:S:S*C*L",\r
+ n, LENGTH of n ge 8 -> '*0', '*T', p, p ls #1000->'*T','*0', SCRE of tree,SCRE of tree > 9999999 -> '*0','*t', GAMES of tree,\r
+ PSWD of tree, (WIZD of tree bitand 4)-> "*TBERSERK", "",(WIZD of tree bitand WIZMASK)->WRD1 of tree bitand 1->"*TWITCH","*TWIZARD", "")\r
+ Outree(CHAIN of tree)\r
+ outree(r)\r
+$)\r
+and Oneoff() be\r
+$( let now,newrec,lastrec,recptr,rec2,old.lastrec,hashbuf=\r
+ today(),0,?,?,0,?,vec 256\r
+ !cbll_(-BUFFERS<<18)bitor(dmpbuff-1)\r
+ 1!cbll_0\r
+ clearvec(dmpbuff, BUFFERS)\r
+ perputt_createfile($6"dsk",game,$6"off",0,0,#17,1)\r
+ useto(perputt,1)\r
+ nextrec_dmpbuff\r
+ setup()\r
+ $( inuuo(perput,cbl)\r
+ rec_dmpbuf\r
+ while LH of rec\r
+ $(\r
+//Do the processing between here...\r
+\r
+ let temp,pswrd=newrec,? //record list pointer\r
+ newrec_newvec(RECLENGTH) //new reclength\r
+ !newrec_temp\r
+ for i=0 to 7 do (2+i)!newrec_i!rec //copy over oldrec\r
+ for i=8 to RECLENGTH-2 do (2+i)!newrec_0 //and zero the rest\r
+ pswrd_9!newrec\r
+ 9!newrec_(pswrd rem ((1<<20)-1))*(pswrd rem ((1<<25)-1))\r
+ if LENGTH of (rec+1)<5 4!newrec_0\r
+ \r
+\r
+//...and here!\r
+ rec+_8\r
+ $)\r
+ unless rec=dmpbuf+2*WDSPERBUF-8 & rec!1 then break\r
+ $) repeat\r
+ \r
+ \r
+ bcntt_3\r
+ for hashno=0 to 252\r
+ $( let nextrec=newrec\r
+ out("****************HASH=:N*****************C*L",hashno)\r
+ lastrec_0\r
+ while nextrec\r
+ $( let recptr=rec2+dmpbuff\r
+ if hashno=hashval(nextrec+3)\r
+ $( out(":s :n*C*L",nextrec+3,bcntt)\r
+ 1!nextrec_lastrec\r
+ lastrec_rec2+(bcntt-1)*WDSPERBUF\r
+ old.lastrec_lastrec\r
+ for i=0 to 11 i!recptr_(i+1)!nextrec\r
+ rec2+_12\r
+ if rec2>128\r
+ $( useto(perputt,bcntt)\r
+ outuuo(perputt,cbll)\r
+ bcntt+_1\r
+ rec2 rem_ 128\r
+ for i=0 to rec2-1 do i!dmpbuff_(i+12-(rec2-1))!nextrec\r
+ $)\r
+ $)\r
+ nextrec_!nextrec\r
+ $)\r
+ hashno!hashbuf_lastrec\r
+ $)\r
+ useto(perputt,bcntt) //tidy up.\r
+ outuuo(perputt,cbll)\r
+ 255!hashbuf_old.lastrec+12\r
+ 254!hashbuf_0\r
+\r
+ for hashno=0 to 255 hashno!dmpbuff_hashno!hashbuf\r
+\r
+ useto(perputt,1)\r
+ outuuo(perputt,cbll) //Output hash table\r
+ \r
+ close(perput)\r
+ deq(sc.channel^perput)\r
+ close(perputt)\r
+ Writes(tty,"*C*LOne-offed in the .OFF file*C*L")\r
+$)\r
+and clearvec(vect,size) be\r
+$[ $MOVE AC, vect\r
+ $HRLI B, 0(AC)\r
+ $HRRI B, 1(AC)\r
+ $SETZM 0(AC)\r
+ $ADD AC, size\r
+ $BLT B, 0(AC)\r
+$]\r
+and yes(rec, str) =valof\r
+write(tty, ":s :s", rec+1, str)<>\r
+$[ $clrbfi\r
+ $inchrw 1\r
+ $caie 1, 'y'\r
+ $cain 1, 'Y'\r
+ $jrst ep\r
+ $cain 1, '*C'\r
+ $jrst yep\r
+ $clrbfi\r
+ $outstr $az"o*C*L"\r
+ $setz 1, 0\r
+ $( return $)\r
+yep: $outchr 'y'\r
+ep: $outstr $az"es*C*L"\r
+$]\r
+\r
+$[ fn: $exit 1, 0\r
+ $jrst fn\r
+$]\r
+\r
+\r
+\r
+\r
+\\\\\\r
+\fSUBFILE: DBADAT.MAC @15:11 16-AUG-1986 <477> (786) \r
+;Copyright (C) 1980 by\r
+;Roy Trubshaw, Richard Bartle & Ronan Flood,\r
+;Essex University, Colchester. CO4 3SQ.\r
+;\r
+; This software is furnished on the understanding that\r
+;it may be used and or copied only with the inclusion of this\r
+;notice. No title or ownership of this software is hereby\r
+;transferred. The information in this software is subject to\r
+;change without notice. No responsibility is assumed for the\r
+;use or reliability of this software.\r
\r
-RELOC\r
+ TITLE Database for MUD version 3\r
+ TWOSEG 400K\r
+ SALL\r
+ .DIRECTIVE SFCOND\r
+ NOSYM\r
\r
-SUMADD: BLOCK 3\r
-VEC: BLOCK 4\r
-NEW: 0\r
-OLD: 0\r
-FLAGS: 0\r
-STATUS: 0\r
+ MAXPLY==^D36\r
\r
-ARGS: .PCJBI\r
- XWD 4,0\r
- XWD 2,0\r
+ IF2 <PRINTX Assembling Database for MUD version 3>\r
\r
-PATHBK: -5\r
- 0\r
- SIXBIT /MUD/\r
- 0\r
-PATHDV: EXP 0, 0, 0\r
-PATHPP: EXP 0, 0, 0, 0\r
-ADDR: .FSSRC\r
-DISC:: BLOCK 1\r
- 0\r
- 0\r
- BLOCK ^D21 ;SHOULD BE ENOUGH FOR MOST SEARCHLISTS...\r
-LOC: EXP -1,0,0\r
- END ..BCPL\r
+ DEFINE FLIST(SIZE,NUM)<\r
+ EXP .+1\r
+ REPEAT NUM-1,<\r
+ EXP .+SIZE\r
+ BLOCK SIZE-1>\r
+ BLOCK SIZE>\r
+ \r
+ DEFINE VEC(SIZE,VALUE<0>)<\r
+ EXP .+1\r
+ IFE VALUE, <BLOCK SIZE>\r
+ IFN VALUE, <REPEAT SIZE, <EXP VALUE>>>\r
+ \r
+STARTL::EXP . ;Address of start of database.\r
+INDEX:: EXP 0 ;Room index.\r
+DICTIO::BLOCK 1 ;Dictionary hash table.\r
+STLIST::BLOCK 1 ;Pointer to start location list.\r
+MAX.RO::BLOCK 1 ;Max number of rooms.\r
+MAX.DE::BLOCK 1 ;Max number of demons.\r
+DEMONS::BLOCK 1 ;Table of demons\r
+GDEMON::EXP 0 ;List of global demons\r
+DATE:: BLOCK 1 ;DECsystem 10 date of creation.\r
+RDATE:: EXP 0 ;DECsystem 10 date of last reset\r
+RHOURS::EXP 0 ;Accumulated time since last Reset\r
+RNDMS:: EXP 0 ;List of room lists for randomisation\r
+FTIME:: EXP 0 ;First time played this version?\r
+TIME:: BLOCK 1 ;DECsystem 10 time of creation.\r
+BACKWD::BLOCK 1 ;Says if a direction has an opposite\r
+TVERB:: BLOCK 1 ;movement check word\r
+NAPCT:: 0 ;number of naps before assume crash\r
+SUPERS::0 ;whether this is superseded by us or not\r
+DEMO:: 0 ;is there a demo on?\r
+RANDIR::0 ;random directions in travel table\r
+CODES:: BLOCK 1 ;vdu manipulation codes.\r
+LOW1:: EXP 0 ;overload measure\r
+LOW2:: EXP 0 ;near-overload measure\r
+TIMES:: EXP .+1 ;vector of lists of playing times\r
+ BLOCK 7\r
+MOTVEC:: BLOCK 1 ;Inverse movement no. to names\r
+MOVERS:: BLOCK 1 ;Objects which are mobile\r
+MVLOCK:: EXP -1 ;So don't try to move above twice at once\r
+DELOCK:: EXP -1 ;Global demon lock\r
+MELTED:: EXP -1 ;Whether objects can move\r
+PEACE:: EXP 0 ;whether can fight or not\r
+SPECT:: EXP 0 ;whether there's a spectacular on\r
+MALE:: VEC ^D10 ;names for males\r
+ ;I bet I forget to alter with MAX.LEVEL...\r
+FEMALE:: VEC ^D10 ;names for females\r
+MUDNAM:: BLOCK ^D27 ;Name of dungeon as BCPL string\r
+MUD6:: EXP 0 ;first 6 letters of above in 6bit\r
+ESXWD:: BLOCK 1 ;memory location for manifest ESSEX constant\r
+PS6:: BLOCK 1 ;first 6 letters of persona file\r
+MAX.ME::BLOCK 1 ;Max number of text messages.\r
+TEXT:: BLOCK 1 ;Table of text messages.\r
+TXTVEC:: BLOCK 1 ;Word count for disc file\r
+INIDR:: EXP -1 ;Initialisation door.\r
+DELDR:: EXP -1 ;Delay door for timing out.\r
+ACTIVE::VEC MAXPLY, -1 ;To ensure you're still playing\r
+PLAYER::EXP -1 ;Stack pointer.\r
+ COUNT==MAXPLY+2 ;2 is the frig factor!\r
+PLYNUM::VEC MAXPLY, <<COUNT=COUNT-1>>\r
+ PURGE COUNT\r
+MQUEUE::VEC MAXPLY ;Message queue.\r
+PNAMES::VEC MAXPLY ;Player names.\r
+JOBNOS::VEC MAXPLY ;Player job numbers. Forget locking it...\r
+KIPS:: VEC MAXPLY ;Times at which people went to sleep.\r
+QDOORS::VEC MAXPLY, -1 ;Doors to message queues.\r
+PDOOR:: EXP -1 ;persona file door\r
+MDOOR:: EXP -1 ;Door to message freelist.\r
+NDOOR:: EXP -1 ;Door to name selection\r
+TABS:: VEC ^D24 ;Combat tables\r
+SHELF:: EXP 0 ;Shelf for arch-wiz items\r
+SHORTM::FLIST 3, 200 ;Short message freelist.\r
+LONGME::FLIST 20, 100 ;Long message freelist.\r
+%RANSE::XWD 1, -1 ;Random number seed.\r
+MAGIC:: EXP 0 ;If non zero u get thrown out.\r
+NOWIZ:: EXP 0 ;true if no wiz's allowed\r
+LOCKED::EXP 0 ;Whether the game is wizard-locked or not\r
+ENDLOC::EXP HERE/^D512 ;Current page\r
+FREE.S::EXP .+1 ;Freestore pointer\r
+ BLOCK 1\r
+HERE==.\r
+END\r
+\r
+\r
+\r
+\r
+\\\\\\r
+\f
\ No newline at end of file
+++ /dev/null
-/*\r
-COPYRIGHT (C) 1980 BY\r
-ROY TRUBSHAW & RICHARD BARTLE,\r
-ESSEX UNIVERSITY, COLCHESTER. CO4 3SQ.\r
-\r
- THIS SOFTWARE IS FURNISHED ON THE UNDERSTANDING THAT\r
-IT MAY BE USED AND OR COPIED ONLY WITH THE INCLUSION OF THIS\r
-NOTICE. NO TITLE OR OWNERSHIP OF THIS SOFTWARE IS HEREBY\r
-TRANSFERRED. THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO\r
-CHANGE WITHOUT NOTICE. NO RESPONSIBILITY IS ASSUMED FOR THE\r
-USE OR RELIABILITY OF THIS SOFTWARE.\r
-*/\r
-\r
-GET "BCL:ACS"\r
-GET "BCL:SCB"\r
-GET "BCL:IOLIB"\r
-GET "DUNGEN"\r
-GET "BCL:RFSLIB"\r
-\r
-$LDTEXT "/RUNAME:POWER"\r
-\r
-EXTERNAL "."\r
-$( FN\r
-$)\r
-\r
-MANIFEST\r
-$( TREESIZE = RECLENGTH+2\r
- RIGHT = RH \ TREESIZE-1\r
- LEFT = LH \ TREESIZE-1\r
- CHAIN = RH \ TREESIZE\r
-$)\r
-\r
-STATIC\r
-$( CBL = VEC 1\r
- DMPBUF = VEC BUFFERS\r
- PERPUT = ?\r
- REC = ?\r
- GENDER = 0\r
- ME = 0\r
- CH = ?\r
- NAME = VEC 1\r
- ROOM = 0\r
- TREE = 0\r
-$)\r
-\r
-LET START() BE\r
-$( LET BCNT=1\r
- OUTPUT:=TTY\r
- OUTS("THE POWER PROGRAM!*C*L")\r
- INPUT:=TTY\r
- $( OUTS("FRIG, START, LEAGUE, TRANSFER, ENUMERATE OR DOT? ")\r
- SWITCHON VALOF\r
- $[ $CLRBFI\r
- $INCHRW 1\r
- $TRZ 1, #40\r
- $] INTO\r
- $(\r
- CASE 'S': OUTS("TART*C*L")\r
- STRAT()\r
- FINISH\r
-\r
-\r
-\r
-\r
-\r
-\r
- CASE 'D': OUTS("OT*C*L")\r
- DOT()\r
- FINISH\r
- CASE 'F': OUTS("RIG*C*L")\r
- BREAK\r
- CASE 'L': OUTS("EAGUE*C*L")\r
- LEAGUE()\r
- FINISH\r
- CASE 'T': OUTS("RANSFER*C*L")\r
- TRANSFER()\r
- FINISH\r
- CASE 'E': OUTS("NUMERATE*C*L")\r
- ENUMERATE()\r
- FINISH\r
- DEFAULT 0 ... #137:\r
- OUTS("*C*LEH?*C*L")\r
- $)\r
- $) REPEAT\r
- SETUP()\r
- READNAME(NAME)\r
- IF !NAME =!"RICHARD" OUTS("*C*LYOU'RE SO NAIVE...*C*L")<>FINISH\r
- $( INUUO(PERPUT,CBL)\r
- REC_DMPBUF\r
- UNTIL PN OF REC=0\/\r
- (NAMESAME(NAME,REC+1)/\VALOF\r
- $( OUT("*C*LDO YOU MEAN :S OF [**,:8]? ",NAME, PN OF REC)\r
- $[ \r
-BACK: $CLRBFI\r
- $INCHRW 1\r
- $IORI 1, '*S'\r
- $CAIN 1, 'Y'\r
- $JRST YES\r
- $CAIN 1, 'N'\r
- $JRST NO\r
- $OUTSTR $AZ "*C*LEH? YES OR NO? "\r
- $JRST BACK\r
-YES: $OUTSTR $AZ "ES*C*L"\r
- $JRST FRONT\r
-NO: $OUTSTR $AZ "O*C*L"\r
- $SETZ 1, 0\r
-FRONT: $CLRBFI\r
- $]\r
- $) ) REC+_RECLENGTH\r
- IF PN OF REC\r
- $( LET SC, SX=SCRE OF REC, WRD1 OF REC BITAND 1\r
- OUTS("CURRENT CHARACTER PROFILE IS:*C*L")\r
- OUT("NAME*T*T:S*C*LSCORE*T*T:N*T:S*C*LSTRENGTH*T:N*C*L",REC+1,SC,LEV(SC,SX),STRN OF REC)\r
- OUT("DEXTERITY*T:N*C*LSTAMINA*T*T:N*T(MAX*T:N)*C*LGAMES PLAYED*T:N*C*LSEX*T*T:SMALE*C*L",\r
- DXTY OF REC,STNA OF REC,STMX OF REC,GAMES OF REC, SX -> "FE", "")\r
- DUMPERSONA()\r
- BREAK\r
- $)\r
- IF REC=DMPBUF+LASTREC TEST REC!1 THEN\r
- $( BCNT+_2\r
- LOOP\r
- $) OR\r
- $( REC!1_TRUE\r
- USETO(PERPUT,BCNT)\r
- OUTUUO(PERPUT,CBL)\r
- $[ $MOVE AC, DMPBUF\r
-\r
-\r
-\r
-\r
-\r
-\r
- $HRLI B, 0(AC)\r
- $HRRI B, 1(AC)\r
- $SETZM 0(AC)\r
- $ADDI AC, BUFFERS\r
- $BLT B, 0(AC)\r
- $]\r
- BCNT+_2\r
- REC_DMPBUF\r
- $)\r
- OUT("NO CURRENT PERSONA! I'LL MAKE ONE FOR YOU, :S*C*L",NAME)\r
- GAMES OF REC_1\r
- WRD1 OF REC_!NAME\r
- WRD2 OF REC_1!NAME\r
- WIZD OF REC_FALSE\r
- DUMPERSONA()\r
- BREAK\r
- $) REPEAT\r
- USETO(PERPUT,BCNT)\r
- OUTUUO(PERPUT,CBL)\r
- CLOSE(PERPUT)\r
- DEQ(SC.CHANNEL^PERPUT)\r
-$)\r
-AND DUMPERSONA() BE\r
-$( OUTS("PREPARE TO FULFILL YOUR WILDEST DREAMS!*C*L")\r
- OUTS("STRENGTH ?"); STRN OF REC_GETNO(STRN)\r
- OUTS("STAMINA (MAX) ?"); STNA OF REC_GETNO(STNA); STMX OF REC_STNA OF REC\r
- OUTS("DEXTERITY ?"); DXTY OF REC_GETNO(DXTY)\r
- OUTS("SCORE ?"); SCRE OF REC_GETNO(SCRE)\r
- OUTS("SEX ?")\r
- $[ $CLRBFI\r
- $INCHRW CH\r
- $]\r
- GENDER_(WRD1 OF REC) BITAND 1\r
- TEST CH='M'\/CH='M' THEN OUTS("ALE*C*L")<>GENDER_0\r
- OR IF CH= 'F'\/CH='F' THEN OUTS("EMALE*C*L")<>\r
- GENDER_1\r
- OUTS("PN ?"); PN OF REC_GETNO(PN,TRUE)\r
- UNLESS PN OF REC PN OF REC_VALOF $[ $GETPPN 1, 0 $]\r
- WRD1 OF REC_((WRD1 OF REC) BITAND ^1) BITOR GENDER\r
- LSTM OF REC_VALOF\r
- $[ $HRRI AC, #11\r
- $HRLI AC, #53\r
- $GETTAB AC, 0\r
- $TRN\r
- $]\r
-$)\r
-AND GETNO(SEL,OCTAL)=VALOF\r
-$( LET CH=VALOF\r
- $[ $CLRBFI\r
- $INCHRW 1\r
- $]\r
- UNLESS NUMBARGS()=2 OCTAL_FALSE\r
- UNLESS '0' LE CH LE '9'\r
- $( $[ $CLRBFI $]\r
- RESULTIS SEL OF REC\r
- $)\r
- PUTBACK(INPUT, CH)\r
- CH_(OCTAL->INOCT,INNO)()\r
- $( LET STK=SC.PUTSTACK^INPUT\r
- SC.PUTSTACK^INPUT, SC.READER^INPUT _ !STK, STK!2\r
-\r
-\r
-\r
-\r
-\r
-\r
- FREEVEC(STK)\r
- $)\r
- RESULTIS CH\r
-$)\r
-AND INOCT(NOPB)=VALOF\r
-$( LET RES=0 AND CH=?\r
- CH_INCH() REPEATUNTIL '0' LE CH LE '7'\r
- WHILE '0' LE CH LE '7' DO\r
- $( RES_(RES<<3)-'0'+CH\r
- CH_INCH()\r
- $)\r
- UNLESS NUMBARGS() PUTBACK(INPUT,CH)\r
- RESULTIS RES\r
-$)\r
-AND READNAME(NM) BE\r
-$( LET N,CH,LINEV=0,?,VEC NAMELENGTH\r
- WRITE(TTY,"NAME: ")\r
- READCH(INPUT,@CH)\r
- WHILE 'A'<=(CH BITOR #40)<='Z' DO\r
- $( N+:1\r
- UNLESS N>NAMELENGTH LINEV!N:='A'<=CH<='Z'->CH+#40,CH\r
- READCH(INPUT,@CH)\r
- $)\r
- !LINEV:=N>NAMELENGTH->NAMELENGTH,N\r
- PACKSTRING(LINEV,NM)\r
- UNTIL CH='*L' DO READCH(INPUT,@CH)\r
-$) REPEATUNTIL LENGTH OF NM\r
-AND DOT() BE\r
-$( LET STFL,NO,CH=0,?,?\r
- WRITES(TTY,"PLEASE ENTER THE JOB NUMBER OF THE ABOUT TO BE DOTTED JOB*C*L(0 FOR ALL OF THEM)*C*L")\r
- WRITES(TTY,"**")\r
- NO_RDNO(TTY)\r
- $( LET RES=?\r
- WRITES(TTY,"DOTTED NICELY OR HORRIBLY N/H? ")\r
- $[ $CLRBFI\r
- $INCHRW CH\r
- $]\r
- STFL_0\r
- IF CH='H' \/ CH='H' THEN STFL_'H'<>WRITES(TTY,"ORRIBLY*C*L")\r
- IF CH='N' \/ CH='N' THEN STFL_'N'<>WRITES(TTY,"ICELY*C*L")\r
- UNLESS STFL WRITES(TTY,"*BINVALID CHARACTER*C*L")<>LOOP\r
- TEST NO THEN RES_DISPOSE(STFL, NO)\r
- OR FOR I=1 TO 200 IF DISPOSE(STFL, I) RES_TRUE\r
- UNLESS RES WRITES(TTY, "*C*L?POWIDW - IT DIDN'T WORK SO STOP PISSING AROUND.*C*L")\r
- FINISH \r
- $) REPEAT\r
-$)\r
-AND DISPOSE(STFL, NO) BE\r
-$[ $SETO 1,0\r
- $PJOB 3,0\r
- $HRRZ 2,STFL\r
- $ADD 2,3\r
- $HRL 2,NO\r
- $CALLI 2,#175\r
- $SETZ 1,0\r
-$]\r
-AND NAMESAME(NAM1,NAM2)=\r
-(!NAM1>>1)=(!NAM2>>1)/\((LENGTH OF NAM1<=4)\/(1!NAM1>>1)=(1!NAM2>>1))\r
-AND STRAT() BE\r
-$( LET RESP=?\r
-\r
-\r
-\r
-\r
-\r
-\r
- $( WRITES(TTY, "*C*LMUD OR VALLEY? ")\r
- $[ $INCHRW 1\r
- $TRZ 1, ' '\r
- $MOVEM 1, RESP\r
- $]\r
- $) REPEATUNTIL RESP='V' \ RESP='M'\r
- WRITES(TTY, RESP='V'->"ALLEY*C*L", "UD*C*L")\r
- RESP_RESP='V'->$6"VALLEY", $6 "MUD"\r
- OUTPUT_CREATETMP(RESP)\r
- READNAME(NAME)\r
- WRITES(TTY, "*C*LROOM: ")\r
- $[ $CLRBFI $]\r
- FOR I=0 TO 5 DO\r
- $( LET LETTER = BYTE 6:30-6*I\r
- AND NEXT = VALOF $[ $INCHRW 1 $]\r
- IF 'A' LE NEXT LE 'Z' NEXT-_'A'-'A'\r
- IF NEXT = '*C' BREAK\r
- LETTER FROM ROOM _ NEXT-' '\r
- $)\r
- $[ $CLRBFI $]\r
- OUT(":S*^C:N*$:N*$:N", NAME,\r
- VALOF $[ $MSTIME 1, 0 $],\r
- VALOF $[ $MSTIME 1, 0 $],\r
- ROOM)\r
- CLOSE(OUTPUT)\r
- RUN($6 "DSK", RESP, $6 "EXE", 0)\r
-$)\r
-\r
-AND SETUP() BE\r
-$( !CBL_(-BUFFERS<<18)BITOR(DMPBUF-1)\r
- 1!CBL_0\r
- IF FALSE\r
- $(\r
-DOGONEIT: PERPUT_CREATEFILE($6"DSK",$6"MUD",$6".PM",0,0,#17,1)\r
- ENQ(SC.CHANNEL^PERPUT)\r
- USETO(PERPUT,2)\r
- OUTUUO(PERPUT,CBL)\r
- CLOSE(PERPUT)\r
- DEQ(SC.CHANNEL^PERPUT)\r
- $)\r
- PERPUT_UPDATEFILE($6"DSK",$6"MUD",".PM",0,LABEL(DOGONEIT),#17,1)\r
- ENQ(SC.CHANNEL^PERPUT)\r
- USETI(PERPUT,1)\r
-$)\r
-\r
-AND LEV(PTS, FEM)=VALOF\r
-$( LET SC=EXP.STEP\r
- FOR I=0 TO 9\r
- $( IF SC GE PTS RESULTIS I\r
- SC+_SC\r
- $)\r
- RESULTIS 9\r
-$)!(FEM!(TABLE\r
- (TABLE "NOVICE",\r
- "WARRIOR",\r
- "HERO",\r
- "CHAMPION",\r
- "SUPERHERO",\r
- "ENCHANTER",\r
- "SORCERER",\r
-\r
-\r
-\r
-\r
-\r
-\r
- "NECROMANCER",\r
- "LEGEND",\r
- "WIZARD"\r
- ),\r
- (TABLE "NOVICE",\r
- "WARRIOR",\r
- "HEROINE",\r
- "CHAMPION",\r
- "SUPERHEROINE",\r
- "ENCHANTRESS",\r
- "SORCERESS",\r
- "NECROMANCESS",\r
- "LEGEND",\r
- "WITCH"\r
- )\r
- )\r
-)\r
-\r
-AND ENQ(CHAN) BE\r
-$( LET ADDR=VEC 4\r
- !ADDR_#1000005\r
- 1!ADDR_142857\r
- 2!ADDR_CHAN\r
- 3!ADDR_$AZ"MUD"+(-1<<18)\r
- 4!ADDR_0\r
- OUT("*C*LENQ. ERROR CODE :8*C*L", VALOF\r
- $[ $MOVE 1, ADDR\r
- $ENQ. 1, 0\r
- $TRNA\r
- $( RETURN $)\r
- $])\r
-$)\r
-\r
-AND DEQ(CHAN) BE\r
-$( LET ADDR=VEC 1\r
- !ADDR_#1000005\r
- 1!ADDR_142857\r
- OUT("*C*LDEQ.ERROR CODE :8*C*L", VALOF\r
- $[ $MOVE 1, ADDR\r
- $HRLI 1, 1\r
- $DEQ. 1, 0\r
- $TRNA\r
- $( RETURN $)\r
- $])\r
-$)\r
-AND TRANSFER() BE\r
-$( LET PEEP, BCNT=?, 1\r
- OUTS("WHERE FROM? (0 FOR EVERYWHERE) ")\r
- PEEP_INOCT(TRUE)\r
- SETUP()\r
- $( INUUO(PERPUT, CBL)\r
- REC_DMPBUF\r
- WHILE PN OF REC\r
- $( IF PN OF REC=PEEP \ PEEP=0\r
- $( OUT(":S: [**,:8] -> ", REC+1, PN OF REC)\r
- PN OF REC_GETNO(PN, TRUE)\r
- $)\r
- REC+_RECLENGTH\r
- $)\r
- USETO(PERPUT, BCNT)\r
-\r
-\r
-\r
-\r
-\r
-\r
- OUTUUO(PERPUT, CBL)\r
- UNLESS REC=DMPBUF+LASTREC & REC!1 BREAK\r
- BCNT+_2\r
- $) REPEAT\r
- CLOSE(PERPUT)\r
- DEQ(SC.CHANNEL^PERPUT)\r
-$)\r
-\r
-AND LEAGUE() BE\r
-$( SETUP()\r
- $( INUUO(PERPUT,CBL)\r
- REC_DMPBUF\r
- WHILE PN OF REC\r
- $( TREE_INSERT(SCRE OF REC, TREE)\r
- REC+_RECLENGTH\r
- $)\r
- UNLESS REC=DMPBUF+LASTREC & REC!1 THEN BREAK\r
- $) REPEAT\r
- CLOSE(PERPUT)\r
- DEQ(SC.CHANNEL^PERPUT)\r
- OUTREE(TREE)\r
- WHILE ME\r
- $( LET P=LH OF ME\r
- OUT("RICHARD*T*T[**,:8]:C*T34359738369*T999*TWIZARD*C*L",P, P LS #1000->'*T','*0')\r
- ME OF_RH\r
- $)\r
-$)\r
-AND ENUMERATE() BE\r
-$( LET NOW=VALOF\r
- $[ $HRLI 1, #53\r
- $HRRI 1, #11\r
- $GETTAB 1, 0\r
- $TRN\r
- $HLRZ 1, 1\r
- $]\r
- SETUP()\r
- OUTPUT_CREATEFILE($6"DSK",$6"POWER",$6"ENM", 0, LABEL(RATS))\r
- OUTS("ENUMERATION OF PERSONAS AS OF ")\r
- OUTTIME()\r
- OUTS(" ON ")\r
- OUTDATE()\r
- OUTS("::*C*L*L")\r
- $( INUUO(PERPUT,CBL)\r
- REC_DMPBUF\r
- WHILE PN OF REC\r
- $( LET T, SX, WZ=NOW-(LH FROM LSTM OF REC), (WRD1 OF REC) BITAND 1, WIZD OF REC\r
- OUT("NAME:*T*T:S*C*LPPN:*T*T[**,:8]*C*LSCORE:*T*T:N*C*LSTRENGTH:*T:N*C*LDEXTERITY:*T:N*C*LSTAMINA:*T:N*TMAX \r
-:N*C*L",\r
- REC+1,PN OF REC,SCRE OF REC,STRN OF REC,DXTY OF REC,STNA OF REC,STMX OF REC)\r
- OUT("LAST GAME:*T:N DAY:S AGO*C*LGAMES:*T*T:N*C*LSEX:*T*T:SMALE*C*L",\r
- T,T=1->"","S",GAMES OF REC,SX->"FE","")\r
- IF WZ BITAND 1 OUT("MODE:*T*TWI:S*C*L", SX->"TCH","ZARD")\r
- IF WZ BITAND 4 OUTS("MODE:*T*TBERSERK*C*L")\r
- OUTS("*C*L*L")\r
- REC+_RECLENGTH\r
- $)\r
- UNLESS REC=DMPBUF+LASTREC & REC!1 THEN BREAK\r
- $) REPEAT\r
- CLOSE(PERPUT)\r
- DEQ(SC.CHANNEL^PERPUT)\r
-\r
-\r
-\r
-\r
-\r
-\r
- CLOSE(OUTPUT)\r
- WRITES(TTY,"*C*LENUMERATED IN DSK:POWER.ENM*C*L")\r
- IF FALSE\r
-RATS: WRITES(TTY,"*C*LCAN'T CREATE DSK:POWER.ENM*C*L")\r
-$)\r
-\r
-AND INSERT(SC, TREE)=VALOF\r
-$( IF TREE TEST SC LS SCRE OF TREE THEN\r
- $( LEFT OF TREE_INSERT(SC, LEFT OF TREE)\r
- RESULTIS TREE\r
- $) OR IF SC GR SCRE OF TREE THEN\r
- $( RIGHT OF TREE_INSERT(SC, RIGHT OF TREE)\r
- RESULTIS TREE\r
- $)\r
- SC_NEWVEC(TREESIZE)\r
- FOR I=0 TO RECLENGTH SC!I_REC!I\r
- SC!(RH FROM RIGHT)_0\r
- IF TREE\r
- $( CHAIN OF SC_CHAIN OF TREE\r
- CHAIN OF TREE_SC\r
- RESULTIS TREE\r
- $)\r
- CHAIN OF SC_0\r
- RESULTIS SC\r
-$)\r
-\r
-AND OUTREE(TREE) BE IF TREE\r
-$( LET L, R, N, P=LEFT OF TREE, RIGHT OF TREE, TREE+1, PN OF TREE\r
- OUTREE(L)\r
- TEST !N=!"RICHARD" THEN\r
- $( LET M=NEWVEC(0)\r
- LH OF M_P\r
- RH OF M_ME\r
- ME_M\r
- $) OR\r
- OUT(":S:C*T[**,:8]:C*T:N*T:N:S:S*C*L",N, LENGTH OF N GE 8 -> '*0', '*T', P, P LS #1000->'*T','*0', SCRE OF TREE, GAMES OF TR\r
-EE,\r
- (WIZD OF TREE BITAND 4)-> "*TBERSERK", "",(WIZD OF TREE BITAND 1)->WRD1 OF TREE BITAND 1->"*TWITCH","*TWIZARD", "")\r
- OUTREE(CHAIN OF TREE)\r
- OUTREE(R)\r
-$)\r
-\r
-$[ FN: $EXIT 1, 0\r
- $JRST FN\r
-$]\r
projects / mud1.git / commitdiff
