-;Copyright (C) 1980 by\r
-;Roy Trubshaw, Richard Bartle & Brian Mallett,\r
-;Essex University, Colchester. CO4 3SQ.\r
+;COPYRIGHT (C) 1980 BY
+;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
-\r
- CODE1==617022\r
- CODE2==13731\r
- CODE3==26262\r
+ SEARCH UUOSYM\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
- 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
+ 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
/ ]\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
+ EXIT\r
+ HALT\r
+NICE: OUTSTR [ASCIZ /\r
+SOMETHING MAGICAL HAS HAPPENED NICELY...\r
/]\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
+ SETOM CTCFLG##\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
- 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
+ JRST WALLY\r
\r
- TITLE Database for MUD version 3\r
- TWOSEG 400K\r
- SALL\r
- .DIRECTIVE SFCOND\r
- NOSYM\r
+RELOC\r
\r
- MAXPLY==^D36\r
+SUMADD: BLOCK 3\r
+VEC: BLOCK 4\r
+NEW: 0\r
+OLD: 0\r
+FLAGS: 0\r
+STATUS: 0\r
\r
- IF2 <PRINTX Assembling Database for MUD version 3>\r
+ARGS: .PCJBI\r
+ XWD 4,0\r
+ XWD 2,0\r
\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
+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
--- /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
