$! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 18-JUN-1993 05:55:12.75 By user MASMUMMY $! $! This VMS_SHARE Written by: $! Andy Harper, Kings College London UK $! $! Acknowledgements to: $! James Gray - Original VMS_SHARE $! Michael Bednarek - Original Concept and implementation $! $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER $! AND EXECUTE AS A COMMAND PROCEDURE ( @name ) $! $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING: $! 1. HI-Q.COM;1 $! $set="set" $set symbol/scope=(nolocal,noglobal) $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID")) $e="write sys$error ""%UNPACK"", " $w="write sys$output ""%UNPACK"", " $ if f$trnlnm("SHARE_LOG") then $ w = "!" $ ve=f$getsyi("version") $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START $ e "-E-OLDVER, Must run at least VMS 4.4" $ v=f$verify(v) $ exit 44 $UNPACK: SUBROUTINE ! P1=filename, P2=checksum $ if f$search(P1) .eqs. "" then $ goto file_absent $ e "-W-EXISTS, File ''P1' exists. Skipped." $ delete 'f'* $ exit $file_absent: $ if f$parse(P1) .nes. "" then $ goto dirok $ dn=f$parse(P1,,,"DIRECTORY") $ w "-I-CREDIR, Creating directory ''dn'." $ create/dir 'dn' $ if $status then $ goto dirok $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped." $ delete 'f'* $ exit $dirok: $ w "-I-PROCESS, Processing file ''P1'." $ if .not. f$verify() then $ define/user sys$output nl: $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1' PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET( SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:= CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b)); LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION( BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1); IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE; MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1; ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")= 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF"; POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r); ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1; COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE, "output_file"));ENDPROCEDURE;Unpacker;QUIT; $ delete/nolog 'f'* $ CHECKSUM 'P1' $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT $ e "-E-CHKSMFAIL, Checksum of ''P1' failed." $ ENDSUBROUTINE $START: $ create 'f' X$ Facility_Name=`09"HI-Q" X$ Facility_Version=`09"V-1.00 18-Mar-1988" X$ Verify=F$Verify(F$TRNLNM("COMMAND_DEBUG")) X$ On Control_Y then goto Exit X$ Set Symbol/Scope=NoGlobal X$! X$! Copyright `A9 (c) 1988, by Michael Bednarek X$! The distribution of this file is unrestricted as long as this notice X$! remains intact. X$! X$! Michael Bednarek, Institute of Applied Economic and Social Research (IAES VR) X$! // Melbourne University,Parkville 3052, AUSTRALIA, Phone:+61 3 344 57 V44 X$! \X/ Domain:u3369429@`7Bmurdu.oz.au `7C ucsvc.dn.mu.oz.au`7D `7C mb@mun Vnari.oz.au X$! "bang":...UUNET!munnari!murdu!u3369429 PSI%23343000301::U33694 V29 X$! X$ Say="Write SYS$Output" X$ Ask="Inquire/NoPunctuation" X$! X$ Gosub Intro X$ Say "Initializing ..." X$ On Control_Y then goto EndGame X$ Gosub Init X$NewGame: Gosub InitTable X$ Gosub DrawBoard X$! X$GetInput: X$ Say CSI,"1;1H"`09! set the cursor always at the top to prevent scrolling X$ Ask Command "" X$ Cmd=Command-"J" X$ Jump=Cmd.nes.Command X$ If F$Locate(".''Cmd'.",Commands).ne.lCommands then gosub 'Cmd X$ Goto GetInput X$EndGame: Set Key/State=DEFAULT/NoLog X$ Delete/Key/NoLog/All/State=(Curious,Curiouser) X$ Set Terminal/NoApplication_Keypad/Line_Editing/Echo X$ Say A,CSI,"23;1H",CSI,"?25h"`09! exit on last line, cursor on X$Exit: X$ Exit 0*F$Verify(Verify)+1 X$!-------------------------------------------------------------------------- V-- X$Intro: X$ Say Facility_Name," ",Facility_Version X$ Type SYS$Input X XA well known one-player game, once implemented by Bill Conley for MS-DOS, Xhere presented by Michael Bednarek, entirely in Vax/VMS DCL. X XA version in AmigaBasic is also available. X X // X \X/ u3369429@`7Bmurdu.oz.au `7C ucsvc.dn.mu.oz.au`7D `7C mb@munnari.oz.au X$ Ask Yes "Do you want help? " X$ If .not.Yes then Return X$ShowHelp: Type SYS$Input X XThe game is played on a board with 33 holes arranged in a cross pattern Xand begins with all except the center hole being filled with a peg. X XThe object of the game is to remove as many pegs as possible by jumping pegs Xeither horizontally or vertically and removing pegs that are jumped over. XNo diagonal moves or moves without jumping are allowed. X XYou move around the board using the numeric keypad keys: X X`09 8 = Up X 4 Left`09`09 6 = Right X`09 2 = Down X XYou jump by pressing PF1 plus a keypad key, e.g. to jump upwards press PF1 K VP8. XPress PF1 twice to exit the game (or F10 on a VT200). XNote: pressing CTRL/Z will not end the game! XPF2 will produce this page again, and PF4 will reset the board. X XGood luck. X$ Read/End_of_File=Exit/Error=Return/Prompt="Hit RETURN to continue"- X`09/Time_Out=30 SYS$Command Yes X$Return: Return X$!-------------------------------------------------------------------------- V-- X$UP: X$ y=CurY-1 X$ x=CurX X$ Goto Play X$RIGHT: X$ y=CurY X$ x=CurX+1 X$ Goto Play X$LEFT: X$ y=CurY X$ x=CurX-1 X$ Goto Play X$DOWN: X$ y=CurY+1 X$ x=CurX X$Play: X$ If F$Type(Table'y''x).nes."" then goto Play1 X$Error: X$ Say BEL X$ Return X$Play1: X$ If Jump then goto Jump X$ Call DrawOne 'F$Integer(CurY*3-2) 'F$Integer(CurX*5+19) 0 &Table'CurY''Cur VX X$ CurY=y X$ CurX=x X$ Call DrawOne 'F$Integer(CurY*3-2) 'F$Integer(CurX*5+19) 7 &Table'CurY''Cur VX X$ Return X$Jump: X$ If Table'CurY''CurX'.ne."1" then goto Error`09! Currently on a peg? X$ If Table'y''x'.ne."1" then goto Error`09`09! Jumping over a peg? X$ jy=CurY+(y-CurY)*2 X$ jx=CurX+(x-CurX)*2 X$ If F$Type(Table'y''x).eqs."" then goto Error`09! Out of bounds? X$ If Table'jy''jx'.ne."0" then goto Error`09! Target empty? X$ Table'CurY''CurX'="0"`09! The current position becomes empty & un-highligh Vted X$ Call DrawOne 'F$Integer(CurY*3-2) 'F$Integer(CurX*5+19) 0 0 X$ Table'y''x'="0"`09! The skipped position becomes empty, too. X$ Call DrawOne 'F$Integer(y*3-2) 'F$Integer(x*5+19) 0 0 X$ Table'jy''jx'="1"`09! The target position becomes filled & highlighted X$ Call DrawOne 'F$Integer(jy*3-2) 'F$Integer(jx*5+19) 7 1 X$ CurY=jy X$ CurX=jx X$ nPegs=nPegs-1 X$ Gosub DrawScore X$Return X$!-------------------------------------------------------------------------- V-- X$Help: X$ Say A,CLS X$ Gosub ShowHelp X$ Gosub DrawBoard X$ Return X$!-------------------------------------------------------------------------- V-- X$Init: X$ If F$GetDVI("TT","TT_DECCRT") then goto Start0 X$ Say "Sorry, HI-Q needs a DEC CRT terminal." X$ Goto Exit X$Start0:If F$Mode().nes."BATCH" then goto Init0 X$ Say "You can't play HI-Q in batch." X$ Goto Exit X$! X$Init0: X$ BEL`5B0,8`5D=7 X$ ESC`5B0,8`5D=27 X$ CSI=ESC+"`5B" X$ CLS=CSI+"2J"+CSI+"1;1H"`09! Clear Screen & Home X$ G=ESC+"(0"`09`09`09! DEC Special Graphics character set X$ A=ESC+"(B"`09`09`09! ASCII character set X$! X$ Set Terminal/Application_Keypad/NoLine_Editing/NoEcho X$ Define/Key/NoLog PF1 ""/Set_State=Curiouser/If_State=Curious X$ Define/Key/NoLog PF2 HELP/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog HELP HELP/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog PF4 NEWGAME/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog KP8 UP/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog KP6 RIGHT/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog KP4 LEFT/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog KP2 DOWN/Terminate/NoEcho/If_State=Curious X$ Define/Key/NoLog F10 EndGame/Terminate/NoEcho/If_State=Curious X$ Set Key/State=Curious/NoLog X$ Define/Key/NoLog KP8 JUP/Terminate/NoEcho/If_State=Curiouser X$ Define/Key/NoLog KP6 JRIGHT/Terminate/NoEcho/If_State=Curiouser X$ Define/Key/NoLog KP4 JLEFT/Terminate/NoEcho/If_State=Curiouser X$ Define/Key/NoLog KP2 JDOWN/Terminate/NoEcho/If_State=Curiouser X$ Define/Key/NoLog PF1 EndGame/Terminate/NoEcho/If_State=Curiouser X$! X$ Commands=".UP.RIGHT.LEFT.DOWN.ENDGAME.HELP.NEWGAME.CHEAT." X$ lCommands=F$Length(Commands) X$ Cmd="" X$ nGames=-1 X$ nPegs=32 X$ BestResult=32 X$ Say CSI,"?25l"`09! Cursor Off X$Return X$!-------------------------------------------------------------------------- V-- X$Cheat: X$InitTable: X$ CurY=0 X$iNextRow: CurX=0 X$ CurY=CurY+1 X$ If CurY.le.7 then goto iNextCol X$ Table44="0" X$ CurY=6 X$ CurX=4 X$ If nPegs.lt.BestResult then BestResult=nPegs X$ nGames=nGames+1 X$ nPegs=32 X$ If Cmd.nes."CHEAT" then Return X$ Table52="1" X$ Table53="1" X$ Table64="1" X$ CurY=5 X$ CurX=2 X$ nPegs=3 X$ Return X$iNextCol: CurX=CurX+1 X$ If CurX.gt.7 then goto iNextRow X$ If (CurY.lt.3 .or. CurY.gt.5).and.(CurX.lt.3 .or. CurX.gt.5) - X`09.or. CurY.eq.4 .and. CurX.eq.4 then goto iNextCol X$ Table'CurY''CurX="1" X$ If Cmd.nes."CHEAT" then goto iNextCol X$ Table'CurY''CurX="0" X$ Goto iNextCol X$!-------------------------------------------------------------------------- V-- X$DrawBoard: X$Say CLS X$ y=0 X$NextRow: x=0 X$ y=y+1 X$ If y.le.7 then goto NextCol X$! X$ Say A,CSI,"3;54H",F$FAO("!SL game!%S played",nGames),CSI,"K" X$ Say CSI,"4;54HBest result was ",BestResult X$ Say CSI,"17;2HKP8 = Up Precede",CSI,"17;54H6 or more left .. nice tr Vy" X$ Say CSI,"18;2HKP6 = Right with",`09CSI,"18;54H5 left .............. goo Vd" X$ Say CSI,"19;2HKP4 = Left PF1",`09CSI,"19;54H4 left ............ better V" X$ Say CSI,"20;2HKP2 = Down to jump",CSI,"20;54H3 left ..... really cleve Vr" X$ Say`09`09`09`09`09CSI,"21;54H2 left ........ a sharpie!" X$ Say CSI,"22;2HPF2 = Help",`09`09CSI,"22;54H1 left ... take a deep bow" X$ Say CSI,"23;2HPF4 = Reset",`09`09CSI,"23;54H1 left in center...perfect" X$ Say CSI,"23;15HPress PF1 twice to exit" X$ Gosub DrawScore X$Return X$NextCol: x=x+1 X$ If x.gt.7 then goto NextRow X$ If F$Type(Table'y''x).eqs."" then goto NextCol X$ Attr=(y.eq.CurY .and. x.eq.CurX)*7 X$ Call DrawOne 'F$Integer(y*3-2) 'F$Integer(x*5+19) 'Attr &Table'y''x X$ Goto NextCol X$!-------------------------------------------------------------------------- V-- X$DrawOne: Subroutine X$! Draws a box, either filled or empty, highlighted or plain. X$! P1 = Row number`09`09P2 = Column number X$! P3 = Attributes for SGR`09P4 = Empty (0) /filled (1) X$ P1=F$Integer(P1)`09! Necessary because of "P1+1" below X$! The next line not only works if P4="0"`7C"1", but also if P4="TABLE44" an Vd X$! TABLE44="0"`7C"1". X$ P4=F$Element(F$Integer('P4),",","Hx x,Hxaax") X$ Say G,CSI,P3,"m",- X CSI,P1,";",P2,"Hlqqk",CSI,P1+1,";",P2,P4,CSI,P1+2,";",P2,"Hmqqj",- X CSI,"0m",A X$EndSubroutine X$!-------------------------------------------------------------------------- V-- X$DrawScore: X$ Say A,CSI,"11;63H",F$FAO("!2SL peg!%S remaining",nPegs),CSI,"K" X$ If nPegs.eq.1 then goto Finish X$! Check whether the player is stuck X$ y=0 X$cNextRow: x=0 X$ y=y+1 X$ If y.le.7 then goto cNextCol X$Finish: Say CSI,"23;2H",CSI,"5;7mPF4 = Reset" X$ Say CSI,"23;15HPress PF1 twice to exit",CSI,"0m",BEL X$ Goto Illuminate X$cNextCol: x=x+1 X$ If x.gt.7 then goto cNextRow X$ If F$Type(Table'y''x).eqs."" then goto cNextCol X$! Look at 3 boxes horizontally and vertically at once X$ If F$Type(Table'y''F$Integer(x+2)).eqs."" then goto cCol X$ Check=Table'y''x+Table'y''F$Integer(x+1)+Table'y''F$Integer(x+2) X$ If Check.eqs."110" .or. Check.eqs."011" then goto Illuminate X$cCol: X$ If F$Type(Table'F$Integer(y+2)''x).eqs."" then goto cNextCol X$ Check=Table'y''x+Table'F$Integer(y+1)''x+Table'F$Integer(y+2)''x X$ If Check.nes."110" .and. Check.nes."011" then goto cNextCol X$Illuminate: X$ If nPegs.gt.6 then Return X$ Goto Illuminate'nPegs X$Illuminate6: X$ Say A,CSI,"17;54H",CSI,"7m6 or more left .. nice try",CSI,"0m" X$ Return X$Illuminate5: X$ Say A,CSI,"17;54H6 or more left .. nice try" X$ Say A,CSI,"18;54H",CSI,"7m5 left .............. good",CSI,"0m" X$ Return X$Illuminate4: X$ Say A,CSI,"18;54H5 left .............. good" X$ Say A,CSI,"19;54H",CSI,"7m4 left ............ better",CSI,"0m" X$ Return X$Illuminate3: X$ Say A,CSI,"19;54H4 left ............ better" X$ Say A,CSI,"20;54H",CSI,"7m3 left ..... really clever",CSI,"0m" X$ Return X$Illuminate2: X$ Say A,CSI,"20;54H3 left ..... really clever" X$ Say A,CSI,"21;54H",CSI,"7m2 left ........ a sharpie!",CSI,"0m" X$ Return X$Illuminate1: X$ Say A,CSI,"21;54H2 left ........ a sharpie!" X$ If Table44.eqs."1" then goto Illuminate0 X$ Say A,CSI,"22;54H",CSI,"7m1 left ... take a deep bow",CSI,"0m" X$ Return X$Illuminate0: X$ Say A,CSI,"23;54H",CSI,"7m1 left in center...perfect",CSI,"0m" X$ Return $ CALL UNPACK HI-Q.COM;1 1663686003 $ v=f$verify(v) $ EXIT