Version 200600727.0by'============================================= CONST Version = "KRef Version 2006-07-27": 'You must have this to run CONST Enhancement = 0: 'Level of minor cosmetic changes, if any '============================================= DIM SHARED LogC AS STRING * 1 DIM SHARED RefLog(1 TO 100) AS STRING DIM SHARED RefLogX AS INTEGER '============================================= DIM SHARED Board(8, 8) AS INTEGER' column, row '1=K 2=Q 3=B 4=N 5=R 6=pawn (White) '7=K 8=R if the piece has moved (re: Castling) '9=P if the pawn can be taken en passent '-1=K .... (Black) '============================================= DIM SHARED VBoard(8, 8) AS INTEGER 'Requested by LegalMove programmer for internal 'use. Not to be saved/restored/referenced elsewhere '============================================= DIM SHARED WBoard(8, 8) AS INTEGER 'Used to keep White's arbitrary placement of Black pieces DIM SHARED BBoard(8, 8) AS INTEGER 'Used to keep Black's arbitrary placement of White pieces '============================================= DIM SHARED SecretKey AS DOUBLE: SecretKey = GetKey ' This is used to encrypt the game between play sessions '============================================= DIM SHARED LogB AS INTEGER ' Last move completed by Black DIM SHARED LogW AS INTEGER '======================================================== CONST GameMax = 52: ' Max number of saved games supported DIM SHARED MenuOption(GameMax + 4) AS STRING '======================================================== DIM SHARED TM%, LM%: TM% = 2: LM% = 3 DTM: DATA 55,89,E5,8B,5E,0C,8B,07,50,8B,5E,0A,8B,07,50,8B DATA 5E,08,8B,0F,8B,5E,06,8B,17,5B,58,1E,07,CD,33,53 DATA 8B,5E,0C,89,07,58,8B,5E,0A,89,07,8B,5E,08,89,0F DATA 8B,5E,06,89,17,5D,CA,08,00 '============================================= CONST ccMin = 33: CONST ccMax = 126 DIM SHARED ccDelta AS INTEGER: ccDelta = ccMax - ccMin + 1 DIM SHARED sysR(150) AS INTEGER: ' Random numbers DIM SHARED sysC(150) AS INTEGER: ' Characters of text '============================================= DIM SHARED ckE AS STRING * 60 DIM SHARED pbm AS INTEGER: 'Playback mode patch ' MAIN DIM PasswordB AS DOUBLE DIM PasswordW AS DOUBLE DIM WhoseTurn AS INTEGER DIM SHARED GameName AS STRING, GameType AS INTEGER DIM SHARED pwW AS STRING * 15, pwB AS STRING * 15 DIM SHARED pwoW AS STRING * 15, pwoB AS STRING * 15 LSET pwW = "": LSET pwB = "": ' Fill with spaces LSET pwoW = "": LSET pwoB = "" CALL Introduction(GameName, GameType) DIM SHARED GotEntries AS INTEGER ' (Boolean) SELECT CASE GameType CASE 1: 'Existing game CALL SecureReadAndDecrypt(GameName, SecretKey, PasswordB, PasswordW, WhoseTurn) pwoW = pwW: pwoB = pwB IF Opened(1, GameName + ".pwd") THEN LINE INPUT #1, L$ ELSE L$ = SPACE$(30) END IF CLOSE #1 IF LEN(L$) <> 30 THEN STOP: L$ = SPACE$(30) IF LEFT$(L$, 15) <> pwW THEN LSET pwW = "" IF RIGHT$(L$, 15) <> pwB THEN LSET pwB = "" CASE 2: 'New game IF GameName = "" THEN RUN GOSUB InitNewGame: CALL Logger("Init", ""): GOSUB SaveGame CASE 3: 'Exit CLS : SYSTEM END SELECT DIM BadPass AS INTEGER DO ' MakeMove cases: 1=Made move 2=Will move later 3=Game Over SELECT CASE WhoseTurn ' WhoseTurn=0=Need PasswordB 1=NeedPassW ' 2=White's move 3=Black's move ' 4=Black needs to acknowledge game over ' 5=White needs to acknowledge game over ' 6=Game Over CASE 0: LogC = "B" PasswordB = GetInitialPassword("Black") IF PasswordB = 0 THEN CLS : SYSTEM WhoseTurn = 1: GOSUB SaveGame CASE 1: LogC = "W" PasswordW = GetInitialPassword("White") IF PasswordW = 0 THEN CLS : SYSTEM WhoseTurn = 2: GOSUB SaveGame NewPassword% = -1 CASE 2: LogC = "W" IF NewPassword% THEN NewPassword% = 0 ELSE IF PasswordW = -1 AND pwW <> SPACE$(15) THEN IF PasswordB = -1 AND pwB <> SPACE$(15) THEN ELSE CALL RefereeSpeaks("Recall") END IF ELSE BadPass = NOT Authorized("White", PasswordW) IF BadPass THEN EXIT DO CALL RefereeSpeaks("Recall") END IF END IF SELECT CASE MakeMoveX("White") CASE 1: WhoseTurn = 3: GOSUB JustMoved CASE 2: EXIT DO: ' Will move later CASE 3: WhoseTurn = 4: GOSUB SaveGame END SELECT CASE 3: LogC = "B" IF PasswordB = -1 AND pwB <> SPACE$(15) THEN IF PasswordW = -1 AND pwW <> SPACE$(15) THEN ELSE CALL RefereeSpeaks("Recall") END IF ELSE BadPass = NOT Authorized("Black", PasswordB) IF BadPass THEN EXIT DO CALL RefereeSpeaks("Recall") END IF SELECT CASE MakeMoveX("Black") CASE 1: WhoseTurn = 2: GOSUB JustMoved CASE 2: EXIT DO: ' Will move later CASE 3: WhoseTurn = 5: GOSUB SaveGame END SELECT CASE 4: LogC = "B" IF PasswordB = -1 AND pwB <> SPACE$(15) THEN IF PasswordW = -1 AND pwW <> SPACE$(15) THEN ELSE CALL RefereeSpeaks("Recall") END IF ELSE BadPass = NOT Authorized("Black", PasswordB) IF BadPass THEN EXIT DO END IF WhoseTurn = 6: GOSUB SaveGame CLS CASE 5: LogC = "W" IF PasswordW = -1 AND pwW <> SPACE$(15) THEN IF PasswordB = -1 AND pwB <> SPACE$(15) THEN ELSE CALL RefereeSpeaks("Recall") END IF ELSE BadPass = NOT Authorized("White", PasswordW) IF BadPass THEN EXIT DO END IF WhoseTurn = 6: GOSUB SaveGame CLS CASE 6: DO LINE INPUT "Show Board from Whose Perspective? B/W: "; p$ IF UCASE$(p$) = "W" THEN K$ = DisplayBoard("BW-W"): EXIT DO IF UCASE$(p$) = "B" THEN K$ = DisplayBoard("BW-B"): EXIT DO LOOP GOSUB PlayBack Restart 0 END SELECT LOOP CLS IF BadPass THEN PRINT "Not Authorized" GOSUB SaveGame Restart 1 PlayBack: DIM lgW AS INTEGER: lgW = FREEFILE IF NOT Opened(lgW, GameName + ".lgW") THEN RETURN DIM lgB AS INTEGER: lgB = FREEFILE IF NOT Opened(lgB, GameName + ".lgB") THEN CLOSE #lgW: RETURN WindowSub "Open" DO PRINT "Want to see the whole game played? "; LINE INPUT "Y/N: "; A$ CLS : PRINT "You entered "; A$ LOOP WHILE INSTR("YyNn", A$) = 0 IF UCASE$(A$) = "N" THEN PRINT "Game will not be displayed": CLOSE #lgW, #lgB: RETURN pbm = 1 GOSUB InitNewGame DIM Moves(1000) AS STRING DIM MoveX AS INTEGER: MoveX = 0 DIM MoveN AS INTEGER: MoveN = 0 CONST n2m = "None to move" DIM b AS STRING ' Load playback script cnt% = 0 DO MoveN = MoveN + 1: c$ = "Move" + STR$(MoveN) + " " GOSUB GetW: IF L$ <> c$ THEN cnt% = cnt% + 1 GOSUB GetB: IF L$ <> c$ THEN cnt% = cnt% + 1 MoveX = MoveX + 1: Moves(MoveX) = c$ DO GOSUB GetW MoveX = MoveX + 1: Moves(MoveX) = L$ LOOP WHILE INSTR(L$, "to move") = 0 DO GOSUB GetB MoveX = MoveX + 1: Moves(MoveX) = L$ LOOP WHILE INSTR(L$, "to move") = 0 LOOP WHILE cnt% < 4 CLOSE #lgW, #lgB ' Prepare it for playback j = 0: FOR i = 1 TO MoveX IF Moves(i) = n2m THEN j = i - 1: EXIT FOR NEXT i FOR i = j + 1 TO MoveX IF Moves(i) = "" THEN ELSEIF Moves(i) = n2m THEN ELSEIF LEFT$(Moves(i), 4) = "Move" THEN ELSE j = j + 1: Moves(j) = Moves(i) END IF NEXT i MoveX = j + 1: Moves(MoveX) = n2m GOSUB PlayItBack RETURN GetW: IF EOF(lgW) THEN L$ = n2m ELSE LINE INPUT #lgW, L$ RETURN GetB: IF EOF(lgB) THEN L$ = n2m ELSE LINE INPUT #lgB, L$ RETURN ShowK: IF LEFT$(K$, 1) = "~" THEN oldk$ = RIGHT$(K$, LEN(K$) - 1) LOCATE , , 1: PRINT oldk$; " "; WHILE INKEY$ <> "": WEND DO: e$ = INKEY$: LOOP WHILE e$ = "": IF e$ = CHR$(27) THEN SYSTEM oldk$ = oldk$ + SPACE$(4) RETURN END IF DIM sw(5) AS STRING DIM swx AS INTEGER IF K$ <> "u4" THEN FOR swx = 1 TO 4: sw(swx) = sw(swx + 1): NEXT swx sw(5) = oldk$ + K$: oldk$ = "" END IF WindowSub "Close --" IF UCASE$(p$) = "W" THEN K$ = "BW-W" ELSE K$ = "BW-B" K$ = DisplayBoard(K$) WindowSub "Open" FOR swx = 1 TO 5: PRINT sw(swx): NEXT swx RETURN PlayItBack: MoveX = 0 DO GOSUB GetVarB: IF LEFT$(b, 4) = "Move" THEN Move$ = b ELSE STOP K$ = Move$ + " (White)": GOSUB ShowK GOSUB GetVarB DO GOSUB DoMoves LOOP WHILE INSTR(b, " to move") = 0 IF b = n2m THEN EXIT DO K$ = Move$ + " (Black)": GOSUB ShowK GOSUB GetVarB DO GOSUB DoMoves LOOP WHILE INSTR(b, " to move") = 0 LOOP WHILE b <> n2m RETURN GetVarB: IF Moves(MoveX) = n2m THEN STOP: 'bug MoveX = MoveX + 1 b = Moves(MoveX) IF INSTR(b, "|") THEN b = LEFT$(b, INSTR(b, "|") - 1) RETURN DoMoves: IF INSTR(b, "esigns") > 0 THEN b = "Resigns" IF LEFT$(b, 3) = "Try" THEN OldTry$ = RIGHT$(b, 5) K$ = "~" + b: GOSUB ShowK GOSUB GetVarB IF b = n2m THEN RETURN IF LEFT$(b, 4) = "Pawn" THEN PawnGone% = -1 K$ = b: GOSUB ShowK IF LEFT$(b, 2) = "Il" OR LEFT$(b$, 2) = "No" THEN ' K$ = "(not tried)": GOSUB ShowK ELSEIF b = n2m THEN STOP WHILE b = n2m: GOSUB GetVarB: PRINT b: STOP: WEND ELSE x1% = INSTR("abcdefgh", MID$(OldTry$, 1, 1)) x2% = INSTR("abcdefgh", MID$(OldTry$, 4, 1)) y1% = VAL(MID$(OldTry$, 2, 1)) y2% = VAL(MID$(OldTry$, 5, 1)) Oldv% = Board(x2%, y2%) Newv% = Board(x1%, y1%) Board(x2%, y2%) = Newv% Board(x1%, y1%) = 0 IF PawnGone% THEN PawnGone% = 0 IF Oldv% = 0 THEN K$ = "(en passent)": GOSUB ShowK IF Newv% > 0 THEN Board(x2%, 5) = 0 ELSE Board(x2%, 4) = 0 END IF END IF ELSE IF ABS(Newv%) = 1 THEN K$ = "" IF x1% = 5 THEN IF x2% = 7 THEN Board(6, y1%) = Board(8, y1%) Board(8, y1%) = 0: K$ = "x" ELSEIF x2% = 3 THEN Board(4, y1%) = Board(1, y1%) Board(1, y1%) = 0: K$ = "x" END IF IF K$ = "x" THEN K$ = "(Castles)": GOSUB ShowK END IF END IF END IF K$ = "u4": GOSUB ShowK END IF ELSEIF INSTR(b, "promotes") > 0 THEN K$ = b: GOSUB ShowK GOSUB GetVarB IF LEFT$(b, 1) <> "P" THEN STOP: 'bug K% = INSTR("KQBNRPKRP", RIGHT$(b, 1)) IF K% = 0 THEN STOP IF Board(x2%, y2%) > 0 THEN Board(x2%, y2%) = K% ELSE Board(x2%, y2%) = -K% END IF K$ = "u4": GOSUB ShowK ELSE K$ = b: GOSUB ShowK END IF GOSUB GetVarB RETURN JustMoved: GotEntries = 0: LSET ckE = "Bogus " + STR$(CDBL(TIMER)) RETURN SaveGame: kW$ = pwW: kB$ = pwB: ' In case these are changed below IF pwW = SPACE$(15) THEN pwW = pwoW IF pwB = SPACE$(15) THEN pwB = pwoB CALL SecureEncryptAndWrite(GameName, SecretKey, PasswordB, PasswordW, WhoseTurn) pwW = kW$: pwB = kB$ RETURN InitNewGame: PasswordW = 0: PasswordB = 0 WhoseTurn = 0 DIM zRow AS INTEGER, zCol AS INTEGER FOR zRow = 3 TO 6: FOR zCol = 1 TO 8: Board(zCol, zRow) = 0: NEXT zCol: NEXT zRow Stuff$ = "54321345": zRow = 1: GOSUB w1: zRow = 8: GOSUB B1 Stuff$ = "66666666": zRow = 2: GOSUB w1: zRow = 7: GOSUB B1 RETURN w1: FOR zCol = 1 TO 8 Board(zCol, zRow) = VAL(MID$(Stuff$, zCol, 1)) NEXT zCol RETURN B1: FOR zCol = 1 TO 8 Board(zCol, zRow) = -VAL(MID$(Stuff$, zCol, 1)) NEXT zCol RETURN SubRun: VIEW PRINT: COLOR 7, 0: CLS : RUN SUB AnnounceMove (c$) DIM Row AS INTEGER, Col AS INTEGER: 'Row/Col of pawn DIM RowT AS INTEGER, ColT AS INTEGER: ' Row/Col of target FOR Col = 1 TO 8 FOR Row = 2 TO 7 SELECT CASE Board(Col, Row) CASE 6, 9: IF c$ = "White" THEN GOSUB WTest CASE -6, -9: IF c$ = "Black" THEN GOSUB BTest END SELECT NEXT Row NEXT Col WindowSub c$ + " to move" EXIT SUB WTest: IF Col = 1 THEN ColT = 2: RowT = Row + 1 IF Board(ColT, RowT) < 0 THEN GOTO TryMove IF Board(ColT, Row) = -9 THEN GOTO TryMove ELSEIF Col = 8 THEN ColT = 7: RowT = Row + 1 IF Board(ColT, RowT) < 0 THEN GOTO TryMove IF Board(ColT, Row) = -9 THEN GOTO TryMove ELSE ColT = Col - 1: RowT = Row + 1 IF Board(ColT, RowT) < 0 THEN GOTO TryMove IF Board(ColT, Row) = -9 THEN GOTO TryMove ColT = Col + 1: RowT = Row + 1 IF Board(ColT, RowT) < 0 THEN GOTO TryMove IF Board(ColT, Row) = -9 THEN GOTO TryMove END IF RETURN BTest: IF Col = 1 THEN ColT = 2: RowT = Row - 1 IF Board(ColT, RowT) > 0 THEN GOTO TryMove IF Board(ColT, Row) = 9 THEN GOTO TryMove ELSEIF Col = 8 THEN ColT = 7: RowT = Row - 1 IF Board(ColT, RowT) > 0 THEN GOTO TryMove IF Board(ColT, Row) = 9 THEN GOTO TryMove ELSE ColT = Col - 1: RowT = Row - 1 IF Board(ColT, RowT) > 0 THEN GOTO TryMove IF Board(ColT, Row) = 9 THEN GOTO TryMove ColT = Col + 1: RowT = Row - 1 IF Board(ColT, RowT) > 0 THEN GOTO TryMove IF Board(ColT, Row) = 9 THEN GOTO TryMove END IF RETURN TryMove: t$ = MID$("abcdefgh", Col, 1) + MID$("12345678", Row, 1) + "-" t$ = t$ + MID$("abcdefgh", ColT, 1) + MID$("12345678", RowT, 1) SELECT CASE LegalMove(t$) CASE 0: RETURN CASE 2: WindowSub c$ + " to move with possible pawn capture(s)" CASE ELSE: STOP: 'bug END SELECT END SUB FUNCTION Authorized% (c$, pw#) COLOR 7, 1: CLS : LOCATE 5, 30 PRINT "Playing game " + CHR$(34) + GameName + CHR$(34) PRINT : PRINT PRINT "Enter the password for " + c$ PRINT "(Just press Enter if you are not that player)" LINE INPUT "Password: "; pw$ IF pw$ = "" THEN EXIT FUNCTION t# = Hash(pw$) IF t# = pw# THEN Authorized% = -1 ELSE Authorized% = 0 END IF END FUNCTION SUB BOARDMAP (b$, OLDX%, OLDY%, x%, y%) REM MAP BOUNDRIES IF (x% - TM%) >= 0 AND (x% - TM%) < 16 AND y% >= LM% AND y% - LM% < 40 THEN ELSE b$ = "OUTOFBOUNDS" END IF END SUB FUNCTION D2S$ (D AS DOUBLE) DIM w AS STRING, S AS STRING, i AS INTEGER w = MKD$(D) FOR i = 1 TO 8 c% = ASC(MID$(w, i, 1)) S = S + CHR$((c% AND 15) + 65) + CHR$(((c% AND 240) / 16) + 65) NEXT i D2S$ = S END FUNCTION FUNCTION DisplayBoard$ (OrigMode$) STATIC Blue AS INTEGER IF NOT Blue OR LEN(OrigMode$) > 1 THEN COLOR 7, 1: Blue = -1 IF pbm = 0 THEN CLS END IF Mode$ = UCASE$(OrigMode$) STATIC ToldPlayer AS INTEGER DIM zC AS INTEGER, zR AS INTEGER, zP AS INTEGER IF pbm > 0 THEN IF pbm = 1 THEN GOSUB Board: pbm = 2 ELSE GOSUB Board END IF SELECT CASE OrigMode$ CASE "W": GOSUB tablepieces: GOSUB White: GOSUB GetMove CASE "B": GOSUB tablepieces: GOSUB Black: GOSUB GetMove CASE "BW-W", "BW-B" GOSUB Both COLOR 7, 1: LOCATE 22, 2: PRINT ""; CASE "w": GOSUB tablepieces: GOSUB White CASE "b": GOSUB tablepieces: GOSUB Black CASE ELSE: STOP: 'bug END SELECT EXIT FUNCTION Both: COLOR 0, 6 IF OrigMode$ = "BW-W" THEN FOR zR = 8 TO 1 STEP -1 FOR zC = 1 TO 8 LOCATE TM% - 1 + (9 * 2) - (zR * 2), LM% - 3 + zC * 5 - 1 zP = Board(zC, zR) IF zP = 0 THEN IF pbm THEN cs = ((zR - 1) * 9) + (zC) IF cs \ 2 = cs / 2 THEN COLOR 0, 7 ELSE COLOR 7, 0 PRINT SPACE$(3); END IF ELSE IF zP < 0 THEN zP = -zP: COLOR 0, 6 ELSE COLOR 7, 1 PRINT " " + MID$("KQBNRPKRP", zP, 1) + " "; END IF NEXT zC NEXT zR ELSE FOR zR = 1 TO 8 STEP 1 FOR zC = 8 TO 1 STEP -1 LOCATE TM% - 1 + (0 * 2) + (zR * 2), 43 - (LM% - 3 + zC * 5 - 1) zP = Board(zC, zR) IF zP = 0 THEN IF pbm THEN cs = ((zR - 1) * 9) + (zC) IF cs \ 2 = cs / 2 THEN COLOR 0, 7 ELSE COLOR 7, 0 PRINT SPACE$(3); END IF ELSE IF zP < 0 THEN zP = -zP: COLOR 0, 6 ELSE COLOR 7, 1 PRINT " " + MID$("KQBNRPKRP", zP, 1) + " "; END IF NEXT zC NEXT zR END IF COLOR 7, 1 RETURN White: COLOR 7, 1 FOR zR = 8 TO 1 STEP -1 FOR zC = 1 TO 8 zP = Board(zC, zR) IF zP > 0 THEN LOCATE TM% - 1 + (9 * 2) - (zR * 2), LM% - 3 + zC * 5 - 1 PRINT " " + MID$("KQBNRPKRP", zP, 1) + " "; ELSE zP = WBoard(zC, zR): IF zP > 0 THEN STOP: 'bug IF zP < 0 THEN LOCATE TM% - 1 + (9 * 2) - (zR * 2), LM% - 3 + zC * 5 - 1 COLOR 0, 6 PRINT " " + MID$("KQBNRPKRP", -zP, 1) + " "; COLOR 7, 1 END IF END IF NEXT zC NEXT zR COLOR 7, 1 RETURN Black: COLOR 0, 6 FOR zR = 1 TO 8 FOR zC = 8 TO 1 STEP -1 zP = Board(zC, zR) IF zP < 0 THEN LOCATE TM% - 1 + (zR * 2), (LM% + 8 * 5) - (LM% - 3 + zC * 5 - 1), 1 PRINT " " + MID$("KQBNRPKRP", -zP, 1) + " "; ELSE zP = BBoard(zC, zR): IF zP < 0 THEN STOP: 'bug IF zP > 0 THEN LOCATE TM% - 1 + (zR * 2), (LM% + 8 * 5) - (LM% - 3 + zC * 5 - 1), 1 COLOR 7, 1 PRINT " " + MID$("KQBNRPKRP", zP, 1) + " "; COLOR 0, 6 END IF END IF NEXT zC NEXT zR COLOR 7, 1 RETURN GetMove: textloc% = POS(1) CALL KEYBOARD(b$, x%, y%, xxx$, Mode$, textloc%, Board%()) IF b$ = CHR$(27) THEN xxx$ = "resign" DisplayBoard$ = xxx$ RETURN Board: LM% = 3: TM% = 3: LEVEL% = 1 LOCATE TM%, LM%, 0 FOR H = 1 TO 8 FOR j = 1 TO 2 FOR i = 1 TO 8 IF H / 2 = H \ 2 THEN IF i / 2 = i \ 2 THEN COLOR 0, 7 ELSE COLOR 7, 0 ELSE IF i / 2 = i \ 2 THEN COLOR 7, 0 ELSE COLOR 0, 7 END IF PRINT SPACE$(5); NEXT i IF H = 8 AND j = 2 THEN ELSE PRINT : LOCATE , LM% NEXT j NEXT H REM BORDER COLOR 7, 0 LOCATE TM% - 1, LM% - 1 PRINT CHR$(218); STRING$(40, 196); CHR$(191) LOCATE , LM% - 1 FOR i = 1 TO 17 PRINT CHR$(179) LOCATE , LM% - 1 NEXT i LOCATE TM%, LM% - 1 FOR i = 1 TO 17 LOCATE , 40 + LM% PRINT CHR$(179) NEXT i LOCATE TM% - 2 + 18, LM% - 1 PRINT CHR$(192); STRING$(40, 196); CHR$(217) REM NUMBERING COLOR 7, 1 LOCATE TM% + 17, LM% + 2 IF Mode$ = "W" OR Mode$ = "BW-W" THEN FOR i% = 1 TO 8 PRINT LCASE$(CHR$(64 + i%)) + SPACE$(4); NEXT i% ELSE FOR i% = 1 TO 8 PRINT LCASE$(CHR$(73 - i%)) + SPACE$(4); NEXT i% END IF LOCATE TM% + 1, 40 + LM% + 2 IF Mode$ = "W" OR Mode$ = "BW-W" THEN FOR i% = 1 TO 8 PRINT CHR$(57 - i%); LOCATE CSRLIN + 2, 40 + LM% + 2 NEXT i% ELSE FOR i% = 1 TO 8 PRINT CHR$(48 + i%); LOCATE CSRLIN + 2, 40 + LM% + 2 NEXT i% END IF RETURN tablepieces: COLOR 7, 0 LOCATE 3, 50 PRINT CHR$(218); STRING$(25, 196); CHR$(191) LOCATE , 50 FOR i% = 1 TO 3 PRINT CHR$(179) + SPACE$(25) LOCATE , 50 NEXT i% LOCATE 4, 50 FOR i% = 1 TO 3 LOCATE , 25 + 51 PRINT CHR$(179) NEXT i% LOCATE 7, 50 PRINT CHR$(192); STRING$(25, 196); CHR$(217) IF Mode$ = "W" THEN COLOR 0, 6 ELSE COLOR 7, 1 A$ = "KQRBNP" LOCATE 5, 52 FOR i% = 1 TO LEN(A$) PRINT " " + MID$(A$, i%, 1) + " "; : LOCATE , POS(1) + 1 NEXT i% COLOR 7, 1 LOCATE 9, 50: PRINT "Mouse Operation:"; LOCATE 11, 50: PRINT "Control an opponent piece by"; LOCATE 12, 50: PRINT "using Right-Click. Control"; LOCATE 13, 50: PRINT "your pieces with Left-Click."; LOCATE 15, 50: PRINT "Options:"; CALL Options(1) RETURN END FUNCTION FUNCTION ExistsAValidMove% (c$) 'this function is more complex than it needs to be in an effort to have a 'function that executes fast. This function is optimized for execution speed, 'but but at the expense of being more complex. 'funtion determines if a there are any legal moves for the color DIM x AS INTEGER, y AS INTEGER, ix AS INTEGER, iy AS INTEGER, n AS INTEGER DIM i AS INTEGER, cx AS INTEGER, cy AS INTEGER, dir AS INTEGER DIM source AS INTEGER IF c$ = "White" THEN dir = 1 ELSE dir = -1 'direction/color indicator n = 0 'assume no legal moves FOR cx = 1 TO 8 FOR cy = 1 TO 8 source = Board(cx, cy) IF SGN(source) = dir THEN ' one of my pieces? '1=K 2=Q 3=B 4=N 5=R 6=pawn (White) '7=K 8=R if the piece has moved (re: Castling) '9=P if the pawn can be taken en passent '-1=K .... (Black) SELECT CASE ABS(source) CASE 2, 3, 5, 8 'queen/bishop/rook make linear moves FOR i = 0 TO 7 'test each direction x = cx: y = cy ix = ((i + 2) MOD 3) - 1 'formulas for step values iy = ((i * 4) \ 10) - 1 DO 'loop for test lines x = x + ix: y = y + iy 'increment IF (x < 1) OR (x > 8) OR (y < 1) OR (y > 8) THEN EXIT DO 'bounds SELECT CASE ABS(source) CASE 3: IF (x = cx) OR (y = cy) THEN EXIT DO 'diagnols only CASE 5, 8: IF (x <> cx) AND (y <> cy) THEN EXIT DO 'ranks/files only END SELECT IF dir = SGN(Board(x, y)) THEN EXIT DO 'blocked by one's own GOSUB dotest: IF n THEN EXIT FOR IF Board(x, y) THEN EXIT DO 'blocked LOOP NEXT i CASE 6, 9 'pawn y = cy + dir: x = cx: GOSUB dotest '1 step IF (cy = 2 + (5 AND (dir = -1))) AND (NOT n) THEN y = cy + (dir * 2): x = cx: GOSUB dotest '2 steps IF (cx > 1) AND (NOT n) THEN y = cy + dir: x = cx - 1: GOSUB dotest 'left capture IF (cx < 8) AND (NOT n) THEN y = cy + dir: x = cx + 1: GOSUB dotest 'right capture CASE 1, 7 'king FOR i = 0 TO 7 'test 1 step in each direction x = cx + ((i + 2) MOD 3) - 1 'formulas y = cy + ((i * 4) \ 10) - 1 IF (x >= 1) AND (x <= 8) AND (y >= 1) AND (y <= 8) THEN 'bounds GOSUB dotest: IF n THEN EXIT FOR END IF NEXT i IF (ABS(source) = 1) AND (NOT n) THEN y = cy: x = cx - 2: GOSUB dotest 'queen's side castle IF NOT n THEN x = cx + 2: GOSUB dotest 'king's side castle END IF CASE 4 'knight FOR i = 0 TO 7 'test 8 "L" shaped moves x = cx + (((i + 1) MOD 2) + 1) * (1 OR (i < 4)) 'formulas y = cy + ((i MOD 2) + 1) * (1 OR (i < 2) OR (i > 5)) IF (x >= 1) AND (x <= 8) AND (y >= 1) AND (y <= 8) THEN 'bounds GOSUB dotest: IF n THEN EXIT FOR END IF NEXT i END SELECT END IF IF n THEN EXIT FOR NEXT cy IF n THEN EXIT FOR NEXT cx ExistsAValidMove% = n EXIT FUNCTION dotest: IF x < 1 OR x > 8 OR y < 1 OR y > 8 THEN STOP: RETURN: 'Mac's Fix useless IF LegalMove%(CHR$(cx + &H60) + CHR$(cy + &H30) + "-" + CHR$(x + &H60) + CHR$(y + &H30)) = 2 THEN n = -1 RETURN END FUNCTION FUNCTION GetInitialPassword# (c$) COLOR 7, 0: CLS : LOCATE 5, 30 PRINT "Playing game " + CHR$(34) + GameName + CHR$(34) PRINT : PRINT PRINT "Choose and enter the password for " + c$ PRINT "(Just press Enter if you are not that player)" LINE INPUT "Password: "; p$ IF p$ = "" THEN GetInitialPassword# = 0: EXIT FUNCTION IF p$ <> c$ THEN GetInitialPassword# = Hash(p$): EXIT FUNCTION '-------------- Compute password for no-password path RANDOMIZE TIMER DO y# = RND * 44778439 y$ = LTRIM$(STR$(y#)) LOOP WHILE LEN(y$) < 16 OR INSTR(y$, "D") > 0 y% = INSTR(y$, ".") IF y% > 0 THEN MID$(y$, y%, 1) = MID$(y$, 16, 1) IF c$ = "White" THEN LSET pwW = y$ ELSE LSET pwB = y$ '-------------- Read current password file (if any) IF Opened(1, GameName + ".pwd") THEN LINE INPUT #1, L$ ELSE L$ = SPACE$(30) CLOSE #1 IF LEN(L$) <> 30 THEN STOP: L$ = SPACE$(30) '-------------- Add the password for White IF c$ = "White" THEN L$ = pwW + RIGHT$(L$, 15) ELSE L$ = LEFT$(L$, 15) + pwB END IF '-------------- Save it OPEN GameName + ".pwd" FOR OUTPUT AS #1 PRINT #1, L$: CLOSE '-------------- Report no password required GetInitialPassword# = -1 END FUNCTION FUNCTION GetKey# GetKey# = 434311.34183# / 8.333 END FUNCTION FUNCTION Hash# (pw$) IF pw$ = "" THEN STOP: ' Bug in calling program CONST c1 = 10000000#: CONST c2 = 84901 e# = RND(-57737): ' Good a place as any to start DIM L AS INTEGER: L = LEN(pw$) DIM pc(100) AS INTEGER: ' To speed up loop below DIM i AS INTEGER, j AS INTEGER FOR i = 1 TO L: pc(i) = ASC(MID$(pw$, i, 1)): NEXT i ' OK, now compute hash FOR i = 1 TO 3 w# = 0 DO WHILE w# < c1 FOR j = 1 TO L w# = w# + SQR(c2 * RND * pc(j)) NEXT j LOOP w# = RND(c1 - w#) NEXT i Hash# = RND * c1 END FUNCTION SUB IntroDualPrint (qi$) FOR x = 1 TO 80 LOCATE , x COLOR INSTR("B2c456W", MID$(qi$, x + 80, 1)), INSTR("B2c456W", MID$(qi$, x, 1)) PRINT CHR$(220); NEXT x LOCATE CSRLIN, 1 END SUB SUB Introduction (n$, t%) CLS qi$ = "................................................................................" qi$ = qi$ + "..........WWWWWWW......................................WW.......................": CALL IntroDualPrint(qi$) qi$ = "........WWcBBBBBBWW................................WW.WcBW......................" qi$ = qi$ + "......WWcBBcccccccBWW.............................WcBWcBcWB.....................": CALL IntroDualPrint(qi$) qi$ = ".....WcBBcccccccccccBW............................WWccBcWcB....................." qi$ = qi$ + ".....WBccccccccccccccWB............................BWccccW......................": CALL IntroDualPrint(qi$) qi$ = "....WcBcccccccccccccccW............................WcBcWccW....................." qi$ = qi$ + "....WBccccccccccccccccWB.......................WWWWWBcWcWWcB....................": CALL IntroDualPrint(qi$) qi$ = "....WBccccccccccccccccWB......................WcBBBBWWcB.BB....................." qi$ = qi$ + ".....WcccccccccccccccWcB.....................WcBcccccWB.........................": CALL IntroDualPrint(qi$) qi$ = ".....WBccccccccccccccWWWWWWWWW..............WcBcccccccW........................." qi$ = qi$ + "......WWcccccccccccWWcBBBBBBBBWW............WBccccccccWB........................": CALL IntroDualPrint(qi$) qi$ = ".......BWWcccccccWWcBBcccccccccWB...........WBccccccccWB........................" qi$ = qi$ + "........WWWWWWWWWcBBcccccccWWWWcB............WcccccccWcB........................": CALL IntroDualPrint(qi$) qi$ = "......WWcBBBBBBBBBcccccccWWcBBBB.............WWcccccWcB........................." qi$ = qi$ + "....WWcBBcccccccccccccWWWcBB................WcBWWWWWcB..........................": CALL IntroDualPrint(qi$) qi$ = "..WWcBBccccccccccccWWWcBBB.................WcBccWBBBB..........................." qi$ = qi$ + ".WcBBccccccccccWWWWcBWB...................WcBcccWB..............................": CALL IntroDualPrint(qi$) qi$ = ".WBcccccWWWWWWWcBBBBcWB..................WcBcccWcB.............................." qi$ = qi$ + "..WWWWWWcBBBBWBBccccccW.................WcBccccWB...............................": CALL IntroDualPrint(qi$) qi$ = "...BBBBBB....WBcccccccWB...............WcBccccWcB..............................." qi$ = qi$ + "..............WccccccccW..............WcBcccccWB................................": CALL IntroDualPrint(qi$) qi$ = "..............WBccccccccW............WcBcccccWcB................................" qi$ = qi$ + "..............WBccccccccWB.......WWWWWWccccccWB.................................": CALL IntroDualPrint(qi$) qi$ = "..............WBcccccccccW......WcBBBBBWWcccWcB................................." qi$ = qi$ + "...............WcccccccccWB....WWBccccccBWWcWB...WWWWWWWWWWWWWWWWWWWWWWWWWWWWW..": CALL IntroDualPrint(qi$) qi$ = "...............WBcccccccccW.....BWWcccccccBWcB...WcccccccccccccccccccccccccccWB." qi$ = qi$ + "...............WBccccccccccW......BWWccccccWB....WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "...............WBccccccccccWB.......BWWcccccW....WcccccccccccccccccccccccccccWB." qi$ = qi$ + "................WcccccccccccW.........BWWcccWB...WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "................WBccccccccccWB..........BWWcWB...WcccccccccccccccccccccccccccWB." qi$ = qi$ + "................WBcccccccccccW............BWcB...WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "................WBccccccccccccWW............B....WcccccccccccccccccccccccccccWB." qi$ = qi$ + ".................WcccccccccccccBW................WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = ".................WBccccccccccccccW...............WcccccccccccccccccccccccccccWB." qi$ = qi$ + ".................WBcccccccccccWWWcWW.............WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = ".................WBccccccWWWWWcBBBcBW............WcccccccccccccccccccccccccccWB." qi$ = qi$ + ".................WBcWWWWWcBBBBBccccccWW..........WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "................WWWWcBBBBBccccccccccccBWWW.......WcccccccccccccccccccccccccccWB." qi$ = qi$ + "................WBBBBcccccccccccccccccccBBWW.....WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "................WBcccccccccccccccccccccccccWW....WcccccccccccccccccccccccccccWB." qi$ = qi$ + "................WBccccccccccccccccccccWWWWWcBB...WcccccccccccccccccccccccccccWB.": CALL IntroDualPrint(qi$) qi$ = "...............WcBccccccccccccccccWWWWcBBBBB.....WWWWWWWWWWWWWWWWWWWWWWWWWWWWWB." qi$ = qi$ + "...............WBccccccccccccWWWWWcBBBB...........BBBBBBBBBBBBBBBBBBBBBBBBBBBBB.": CALL IntroDualPrint(qi$) qi$ = "..............WcBcccccccWWWWWcBBBBB............................................." qi$ = qi$ + ".............WcBccccWWWWcBBBBB..................................................": CALL IntroDualPrint(qi$) qi$ = "............WcBWWWWWcBBBB......................................................." qi$ = qi$ + "............WWWcBBBBB...........................................................": CALL IntroDualPrint(qi$) qi$ = ".............BBB................................................................" LOCATE 15, 51: COLOR 7, 3 PRINT STRING$(27, 220) 'designed for chr$(196), eh. COLOR 7, 0 LOCATE 25, 40: PRINT Version; SPACE$(5); " Level:"; Enhancement; LOCATE 14, 52: COLOR 0, 3: PRINT "Kriegspiel Referee - Menu" CALL IntroListFiles CALL IntroMenu(n$, t%) END SUB SUB IntroListFiles SHELL "dir *.ksg /b /on > ksgtemp.txt" ' dir one line format sort by name to... MenuCount = 1: MenuOption(MenuCount) = "New Game" OPEN "ksgtemp.txt" FOR INPUT AS #1 DO IF EOF(1) THEN EXIT DO LINE INPUT #1, q$: IF LTRIM$(q$) <> "" THEN q$ = RTRIM$(q$) 'no .ksg, all lower but cap first letter IF LEN(q$) > 4 THEN q$ = LEFT$(LCASE$(q$), LEN(q$) - 4) MID$(q$, 1, 1) = UCASE$(LEFT$(q$, 1)) END IF MenuCount = MenuCount + 1: MenuOption(MenuCount) = q$ IF MenuCount > GameMax + 1 THEN EXIT DO END IF LOOP CLOSE KILL "ksgtemp.txt" IF MenuCount > GameMax + 1 THEN CLS : PRINT "Sorry, you have too many saved games." PRINT "Erase some and try again." SYSTEM END IF MenuCount = MenuCount + 1: MenuOption(MenuCount) = "Quit" MenuCount = MenuCount + 1: MenuOption(MenuCount) = ""'make sure it's empty IF MenuCount > GameMax + 2 THEN MenuOption(1) = "Quit (Can't start New)" END SUB SUB IntroMenu (n$, t%) ' 'run this after you create the background intro screen. ' 'this returns the variable Typed which is=-1 for ESC, or selected 1 to [etc.] ShowOddMenuLegend = 1 'i like it. if you hate it, turn it off :) ' last option must be empty... FinalOptionSameAsEscKey = 1 'set to 0 if you don't want last option to Quit ' count menu options numenuopts = -1 DO numenuopts = numenuopts + 1 LOOP UNTIL MenuOption(numenuopts + 1) = "" ' the big messy loop that does everything :( ' ...but i'm still very fond of it ;) Typed = 1 DO menulegend$ = SPACE$(6) IF numenuopts > 1 THEN SELECT CASE Typed CASE IS = 1 menulegend$ = CHR$(32) + CHR$(25) + CHR$(32) + CHR$(25) + CHR$(32) + CHR$(25) CASE IS = numenuopts menulegend$ = CHR$(24) + CHR$(32) + CHR$(24) + CHR$(32) + CHR$(24) + CHR$(32) CASE ELSE menulegend$ = CHR$(24) + CHR$(32) + CHR$(24) + CHR$(25) + CHR$(32) + CHR$(25) END SELECT END IF IF wheretohlight = 0 THEN wheretohlight = 1 menuline = 0 ' display up and down arrows IF ShowOddMenuLegend <> 0 THEN COLOR 7, 1 FOR menulegendy = 16 TO 21 LOCATE menulegendy, 77 PRINT MID$(menulegend$, menulegendy - 15, 1) NEXT menulegendy END IF ' type and highlight menu DO menuline = menuline + 1: IF dispstart < 1 THEN dispstart = 1 LOCATE menuline + 15, 51, 0: htemp$ = MenuOption(menuline + dispstart - 1) IF menuline = wheretohlight THEN COLOR 11, 0 ELSE COLOR 0, 3 PRINT LEFT$(htemp$ + SPACE$(27), 27 - SGN(ABS(ShowOddMenuLegend))) LOOP UNTIL menuline >= 6 OR menuline + dispstart - 1 >= numenuopts ' arrow key handler designed to work in QB and FB without modification ' note: rest of routine NOT tested in FB... but should avoid chr$(0) problem. DO: keyput$ = INKEY$: LOOP UNTIL keyput$ <> "" 'simulate input$(1) with inkey$ IF keyput$ = "=" THEN IF NOT Opened(1, "CurGame.txt") THEN COLOR 7, 0 PRINT "No current game to start" ELSE LINE INPUT #1, GameName: CLOSE #1 n$ = GameName: t% = 1 COLOR 7, 1: CLS EXIT SUB END IF END IF IF LEN(keyput$) > 1 THEN MID$(keyput$, 1, 1) = CHR$(255) IF INSTR("234567890", keyput$) AND numenuopts = 1 THEN keyput$ = "ab" 'fixed SELECT CASE LCASE$(keyput$) CASE CHR$(255) + "h", CHR$(255) + "k", CHR$(255) + "i" 'up (also left or pgup) IF wheretohlight > 1 THEN wheretohlight = wheretohlight - 1 ELSE IF dispstart > 1 THEN dispstart = dispstart - 1 END IF Typed = dispstart + wheretohlight - 1 CASE CHR$(255) + "p", CHR$(255) + "m", CHR$(255) + "q" 'down (also rt or pgdn) IF Typed < numenuopts THEN IF wheretohlight < 6 THEN wheretohlight = wheretohlight + 1 ELSE IF dispstart + 5 < numenuopts THEN dispstart = dispstart + 1 END IF Typed = dispstart + wheretohlight - 1 END IF CASE CHR$(27) Typed = -1 'quit! CASE SPACE$(1), CHR$(13) 'or enter Typed = Typed + .5 'selection! CASE "1", "2", "3", "4", "5", "6", "7", "8", "9" ' allow actual numbers 1 through 9 IF numenuopts = 1 THEN IF keyput$ = "1" THEN Typed = Typed + .5 'treat specially as enter key ELSE ' normal IF VAL(keyput$) <= numenuopts THEN dispstart = 0 DO: dispstart = dispstart + 1: LOOP UNTIL dispstart + 5 >= VAL(keyput$) wheretohlight = VAL(keyput$) - dispstart + 1 Typed = dispstart + wheretohlight - 1 END IF END IF CASE ELSE COLOR 7, 0: LOCATE 15, 1 PRINT "Use Arrow Keys to highlight an item" PRINT "Use Enter key to select highlighted item" Restart 0 END SELECT LOOP UNTIL Typed < 0 OR Typed <> INT(Typed): Typed = INT(Typed) IF Typed = numenuopts AND FinalOptionSameAsEscKey THEN Typed = -1 COLOR 7, 0 ' yay... ' integrate with mac's design: SELECT CASE Typed CASE -1 n$ = "": t% = 3 'quit CASE 1 IF MenuOption(1) = "New Game" THEN n$ = NewGame: IF n$ = "" THEN CALL Introduction(n$, t%) ELSE t% = 2'new ELSE CLS : PRINT "Erase some games if you want to same new ones" LINE INPUT "Press Enter to acknowledge: "; n$ n$ = "": t% = 3 'quit END IF OPEN "CurGame.txt" FOR OUTPUT AS #1: PRINT #1, n$: CLOSE CASE ELSE n$ = MenuOption(Typed): t% = 1 'continue END SELECT IF n$ = "" OR t% <> 1 THEN EXIT SUB OPEN "CurGame.txt" FOR OUTPUT AS #1: PRINT #1, n$: CLOSE END SUB FUNCTION IsInCheck$ (c$) 'tests whether the king is in check DIM x AS INTEGER, y AS INTEGER, ix AS INTEGER, iy AS INTEGER, n AS INTEGER DIM i AS INTEGER, cx AS INTEGER, cy AS INTEGER, dir AS INTEGER DIM t AS STRING * 3 IF c$ = "White" THEN dir = 1 ELSE dir = -1 cx = 666 'in case there is no king DO FOR x = 1 TO 8 FOR y = 1 TO 8 SELECT CASE dir * Board(x, y) CASE 1, 7: cx = x: cy = y: EXIT DO 'find king END SELECT NEXT y NEXT x LOOP UNTIL -1 'this loop exists only for the convenient EXIT DO, cheap substitute for GOTO n = 0 'assume not in check IF cx <> 666 THEN 'king exists FOR i = 0 TO 7 'test each linear direction x = cx: y = cy 'ix = ((i + 2) MOD 3) - 1 'could be replaced with a SELECT CASE 'iy = ((i * 4) \ 10) - 1 'not sure which would be more efficient SELECT CASE i 'this select case block accomplishes the same thing CASE 0: ix = 1: iy = -1 CASE 1: ix = -1: iy = -1 CASE 2: ix = 0: iy = -1 CASE 3: ix = 1: iy = 0 CASE 4: ix = -1: iy = 0 CASE 5: ix = 0: iy = 1 CASE 6: ix = 1: iy = 1 CASE 7: ix = -1: iy = 1 END SELECT DO 'loop to test the lines x = x + ix: y = y + iy 'increment IF (x < 1) OR (x > 8) OR (y < 1) OR (y > 8) THEN EXIT DO 'bounds '1=K 2=Q 3=B 4=N 5=R 6=pawn (White) '7=K 8=R if the piece has moved (re: Castling) '9=P if the pawn can be taken en passent '-1=K .... (Black) SELECT CASE Board(x, y) * dir 'what's there? CASE IS > 0, -4: EXIT DO 'blocked by one of mine, or enemy knight CASE -1, -7: IF (ABS(x - cx) > 1) OR (ABS(y - cy) > 1) THEN EXIT DO ELSE GOSUB orit CASE -2: GOSUB orit CASE -3: IF (x = cx) OR (y = cy) THEN EXIT DO ELSE GOSUB orit CASE -5, -8: IF (x <> cx) AND (y <> cy) THEN EXIT DO ELSE GOSUB orit CASE -6, -9: IF (ABS(x - cx) <> 1) OR ((y - cy) <> dir) THEN EXIT DO ELSE GOSUB orit END SELECT LOOP NEXT i FOR i = 0 TO 7 '"L" shaped knight moves 'x = cx + (((i + 1) MOD 2) + 1) * (1 OR (i < 4)) 'y = cy + ((i MOD 2) + 1) * (1 OR (i < 2) OR (i > 5)) SELECT CASE i 'does the same as formula CASE 0: x = cx - 2: y = cy - 1 CASE 1: x = cx - 1: y = cy - 2 CASE 2: x = cx - 2: y = cy + 1 CASE 3: x = cx - 1: y = cy + 2 CASE 4: x = cx + 2: y = cy + 1 CASE 5: x = cx + 1: y = cy + 2 CASE 6: x = cx + 2: y = cy - 1 CASE 7: x = cx + 1: y = cy - 2 END SELECT IF (x >= 1) AND (x <= 8) AND (y >= 1) AND (y <= 8) THEN 'bounds IF Board(x, y) * dir = -4 THEN n = n OR 1 'enemy knight? END IF NEXT i END IF t = "---" 'create string IF n AND 1 THEN MID$(t, 1, 1) = "N" IF n AND 2 THEN MID$(t, 2, 1) = "L" IF n AND 4 THEN MID$(t, 2, 1) = "S" IF n AND 8 THEN MID$(t, 3, 1) = "R" IF n AND 16 THEN MID$(t, 3, 1) = "F" IsInCheck$ = t EXIT FUNCTION orit: SELECT CASE i CASE 3, 4: n = n OR 8 'rank CASE 2, 5: n = n OR 16 'file CASE 0, 7: IF (cx > 4) XOR (cy > 4) THEN n = n OR 2 ELSE n = n OR 4 '\ CASE 1, 6: IF (cx > 4) XOR (cy > 4) THEN n = n OR 4 ELSE n = n OR 2 '/ END SELECT RETURN END FUNCTION FUNCTION ispathblocked% (sx AS INTEGER, sy AS INTEGER, dx AS INTEGER, dy AS INTEGER, which AS INTEGER) 'line must be a valid linear move. Input is assumed to be valid! 'if blocked by one's own, returns 1 'if blocked by enemy, and not blocked by one's own, returns 2 'if not blocked, returns 0 DIM x AS INTEGER, y AS INTEGER, ix AS INTEGER, iy AS INTEGER, cnt AS INTEGER DIM n AS INTEGER, i AS INTEGER ix = SGN(dx - sx): iy = SGN(dy - sy) 'set direction of move cnt = ABS(dx - sx) OR ABS(dy - sy) 'counter x = sx: y = sy FOR i = 1 TO cnt - 1 x = x + ix: y = y + iy 'increment IF Board(x, y) THEN 'sensitive to color, because of "illegal" vs. "not possible" IF which <> SGN(Board(x, y)) THEN n = 2 ELSE n = 1: EXIT FOR END IF NEXT i ispathblocked% = n END FUNCTION FUNCTION isthreatened% (bi AS INTEGER, cx AS INTEGER, cy AS INTEGER, dir AS INTEGER) 'this function assumes valid input DIM x AS INTEGER, y AS INTEGER, ix AS INTEGER, iy AS INTEGER, n AS INTEGER DIM i AS INTEGER, b AS INTEGER n = 0 'assume not threatened FOR i = 0 TO 7 ' tests each linear direction x = cx: y = cy 'ix = ((i + 2) MOD 3) - 1 'could be replaced with a SELECT CASE 'iy = ((i * 4) \ 10) - 1 'not sure which would be more efficient SELECT CASE i CASE 0: ix = 1: iy = -1 CASE 1: ix = -1: iy = -1 CASE 2: ix = 0: iy = -1 CASE 3: ix = 1: iy = 0 CASE 4: ix = -1: iy = 0 CASE 5: ix = 0: iy = 1 CASE 6: ix = 1: iy = 1 CASE 7: ix = -1: iy = 1 END SELECT DO 'test the lines x = x + ix: y = y + iy 'increment IF (x < 1) OR (x > 8) OR (y < 1) OR (y > 8) THEN EXIT DO 'bounds '1=K 2=Q 3=B 4=N 5=R 6=pawn (White) '7=K 8=R if the piece has moved (re: Castling) '9=P if the pawn can be taken en passent '-1=K .... (Black) IF bi = 0 THEN 'which array are we working with? b = Board(x, y) ELSE b = VBoard(x, y) END IF SELECT CASE b * dir 'what do we have? CASE IS > 0, -4: EXIT DO 'blocked by one of my own, or enemy knight CASE -1, -7: IF (ABS(x - cx) > 1) OR (ABS(y - cy) > 1) THEN EXIT DO ELSE n = -1: EXIT FOR CASE -2: n = -1: EXIT FOR CASE -3: IF (x = cx) OR (y = cy) THEN EXIT DO ELSE n = -1: EXIT FOR CASE -5, -8: IF (x <> cx) AND (y <> cy) THEN EXIT DO ELSE n = -1: EXIT FOR CASE -6, -9: IF (ABS(x - cx) <> 1) OR ((y - cy) <> dir) THEN EXIT DO ELSE n = -1: EXIT FOR END SELECT LOOP NEXT i IF NOT n THEN FOR i = 0 TO 7 'test "L" shaped directions 'x = cx + (((i + 1) MOD 2) + 1) * (1 OR (i < 4)) 'y = cy + ((i MOD 2) + 1) * (1 OR (i < 2) OR (i > 5)) SELECT CASE i CASE 0: x = cx - 2: y = cy - 1 CASE 1: x = cx - 1: y = cy - 2 CASE 2: x = cx - 2: y = cy + 1 CASE 3: x = cx - 1: y = cy + 2 CASE 4: x = cx + 2: y = cy + 1 CASE 5: x = cx + 1: y = cy + 2 CASE 6: x = cx + 2: y = cy - 1 CASE 7: x = cx + 1: y = cy - 2 END SELECT IF (x >= 1) AND (x <= 8) AND (y >= 1) AND (y <= 8) THEN 'bounds IF bi = 0 THEN 'which array are we working with? b = Board(x, y) ELSE b = VBoard(x, y) END IF IF (b * dir) = -4 THEN n = -1: EXIT FOR 'enemy knight? END IF NEXT i END IF isthreatened% = n END FUNCTION SUB KEYBOARD (b$, x%, y%, xxx$, Mode$, textloc%, Board%()) LOCATE , , 0 DO EX% = 1: CALL MDRIVER(EX%, b$, x%, y%, Mode$, Board%()) DO b$ = INKEY$ EX% = 2: CALL MDRIVER(EX%, b$, x%, y%, Mode$, Board%()) IF b$ = CHR$(27) THEN EXIT DO: REM RESIGN IF b$ = "OUTOFBOUNDS" THEN b$ = "" LOOP UNTIL b$ <> "" EX% = -1: CALL MDRIVER(EX%, b$, x%, y%, Mode$, Board%()) IF b$ = CHR$(27) AND MOVESTAT% <> 0 THEN x% = OLDX%: y% = OLDY%: GOSUB CANCELMOVE IF b$ = "L-CLICK" THEN CALL SNAPTOCENTER(x%, y%) IF MOVESTAT% = 0 THEN LOCATE x%, y% OLDX% = x%: OLDY% = y% Piece$ = CHR$(SCREEN(x%, y%)) IF Piece$ <> CHR$(32) THEN COLORIT% = SCREEN(x%, y%, 1) IF COLORIT% = 23 THEN IF Mode$ = "B" THEN Piece$ = CHR$(32) ELSEIF COLORIT% = 96 THEN IF Mode$ = "W" THEN Piece$ = CHR$(32) ELSE STOP: 'bug: color other than 23 and 96 END IF END IF IF Piece$ = CHR$(32) THEN b$ = "": REM DO OVER EMPTY SQUARE ELSE COLOR COLORIT% MOD 16 + 16, COLORIT% \ 16 PRINT Piece$; COLOR 7, 1: b$ = "" GOSUB COORDERNATES CALL Options(2) LOCATE 23, textloc%: PRINT OLDALPHA$ + OLDNUMBER$ + "-"; IF COLORIT% = 23 THEN MOVESTAT% = 1 ELSE MOVESTAT% = -1 END IF ELSE IF OLDX% = x% AND OLDY% = y% THEN CALL Options(1) GOSUB CANCELMOVE ELSE CALL Options(4) GOSUB COORDERNATES xxx$ = OLDALPHA$ + OLDNUMBER$ + "-" + NEWALPHA$ + NEWNUMBER$ LOCATE 23, textloc%: PRINT xxx$; : SLEEP 1 LOCATE OLDX%, OLDY% - 1: COLOR COLORIT% MOD 16, COLORIT% \ 16: PRINT " " + Piece$ + " "; COLOR 7, 1 EXIT DO END IF END IF END IF IF b$ = CHR$(27) THEN EXIT DO LOOP LOCATE , , 1 EXIT SUB COORDERNATES: IF Mode$ = "B" THEN OLDNUMBER$ = LTRIM$(STR$(1 + INT((OLDX% - TM% + 1) / 2.1))) OLDALPHA$ = LCASE$(CHR$(72 - INT((OLDY% - LM% + 1) / 5.1))) NEWNUMBER$ = LTRIM$(STR$(1 + INT((x% - TM% + 1) / 2.1))) NEWALPHA$ = LCASE$(CHR$(72 - INT((y% - LM% + 1) / 5.1))) ELSE OLDNUMBER$ = LTRIM$(STR$(8 - INT((OLDX% - TM% + 1) / 2.1))) OLDALPHA$ = LCASE$(CHR$(65 + INT((OLDY% - LM% + 1) / 5.1))) NEWNUMBER$ = LTRIM$(STR$(8 - INT((x% - TM% + 1) / 2.1))) NEWALPHA$ = LCASE$(CHR$(65 + INT((y% - LM% + 1) / 5.1))) END IF RETURN CANCELMOVE: LOCATE x%, y% COLOR COLORIT% MOD 16, COLORIT% \ 16 PRINT Piece$; COLOR 7, 1 MOVESTAT% = 0 IF b$ <> CHR$(27) THEN b$ = "" LOCATE 23, textloc%: PRINT SPACE$(80 - POS(1)); RETURN END SUB FUNCTION ksgDecrypt$ (K#, Encrypted$) DIM L AS INTEGER: L = LEN(Encrypted$) - 10 y = RND(-ksgMKey(LEFT$(Encrypted$, 10))): y = RND(-RND * K#) DIM w AS STRING: w = RIGHT$(Encrypted$, L) FOR i = 1 TO L c% = ASC(MID$(w, i, 1)) IF c% < ccMin OR c% > ccMax THEN STOP: 'bug sysC(i) = c% - ccMin NEXT i FOR i = 1 TO L: sysR(i) = 1 + INT(RND * L): NEXT i ' ================================ Decrypt start FOR iteration = 1 TO 50 FOR i = 1 TO L c% = sysC(i) + INT(RND * ccDelta) IF c% >= ccDelta THEN c% = c% - ccDelta sysC(i) = c% NEXT i NEXT iteration FOR i = 1 TO L: SWAP sysC(i), sysC(sysR(i)): NEXT i ' ==============vvvvv============= Decrypt end w = "": FOR i = 1 TO L: w = w + CHR$(ccMin + sysC(i)): NEXT i ksgDecrypt$ = w END FUNCTION FUNCTION ksgEncrypt$ (K#, Clear$) DIM w AS STRING: w = Clear$ DIM L AS INTEGER: L = LEN(w) DIM i AS INTEGER STATIC ornd AS DOUBLE IF ornd = 0 THEN RANDOMIZE TIMER: ornd = RND ornd = RND(-ornd) FOR i = 1 TO 10: mkey$ = mkey$ + CHR$(ccMin + INT(RND * (ccMax - ccMin + 1))): NEXT i y = RND(-ksgMKey(mkey$)): y = RND(-RND * K#) FOR i = 1 TO L c% = ASC(MID$(w, i, 1)) IF c% < ccMin OR c% > ccMax THEN STOP: 'bug sysC(i) = c% - ccMin NEXT i FOR i = 1 TO L: sysR(i) = 1 + INT(RND * L): NEXT i ' =============^^^^^============== Encrypt start FOR i = L TO 1 STEP -1: SWAP sysC(i), sysC(sysR(i)): NEXT i FOR iteration = 1 TO 50 FOR i = 1 TO L c% = sysC(i) - INT(RND * ccDelta) IF c% < 0 THEN c% = c% + ccDelta sysC(i) = c% NEXT i NEXT iteration ' ================================ Encrypt end w = "": FOR i = 1 TO L: w = w + CHR$(ccMin + sysC(i)): NEXT i ksgEncrypt$ = mkey$ + w END FUNCTION FUNCTION ksgMKey# (mkey$) w1# = 3: w2# = 5: w3# = 7: w4# = 11 FOR i = 1 TO 10 c% = ASC(MID$(mkey$, i, 1)) - ccMin w1# = w1# + (c% * i) w2# = w2# + (c% * (11 - i)) IF c% AND 1 THEN w3# = w3# + (c% * i) ELSE w4# = w4# + (c% * 1) END IF NEXT i ksgMKey# = (w1# / w2#) * (w3# * w4#) END FUNCTION FUNCTION LegalMove% (movestr AS STRING) 'format "a1-h8" 'returns 0 if not possible, 1 if illegal, 2 if legal DIM sx AS INTEGER, sy AS INTEGER, dx AS INTEGER, dy AS INTEGER DIM source AS INTEGER, why AS INTEGER, x AS INTEGER, y AS INTEGER DIM kx AS INTEGER, ky AS INTEGER, dir AS INTEGER, block AS INTEGER why = 2 'assume legal sx = ASC(LEFT$(movestr, 1)) - &H60 'get coordinates from string sy = ASC(MID$(movestr, 2, 1)) - &H30 dx = ASC(MID$(movestr, 4, 1)) - &H60 dy = ASC(MID$(movestr, 5, 1)) - &H30 '1=K 2=Q 3=B 4=N 5=R 6=pawn (White) '7=K 8=R if the piece has moved (re: Castling) '9=P if the pawn can be taken en passent '-1=K .... (Black) source = Board(sx, sy) 'piece to move IF source = 0 THEN why = 1: GOTO outnow 'trying to move nothing? dir = SGN(source) 'note the color of the piece IF SGN(Board(dx, dy)) = dir THEN why = 1: GOTO outnow 'taking one's own piece FOR x = 1 TO 8 FOR y = 1 TO 8 VBoard(x, y) = Board(x, y) 'update vboard SELECT CASE dir * Board(x, y) CASE 1, 7: kx = x: ky = y 'find king END SELECT IF ABS(Board(x, y)) = 9 THEN VBoard(x, y) = SGN(Board(x, y)) * 6 'pawns no longer subject to en passant END IF NEXT y NEXT x VBoard(sx, sy) = 0 'remove piece from starting square in vboard SELECT CASE ABS(source) CASE 1 'king that hasn't moved IF (ABS(sx - dx) > 1) OR (ABS(sy - dy) > 1) THEN 'not a normal move IF sy <> dy THEN why = 1: GOTO outnow 'illegal SELECT CASE dx CASE 3 'queen's side castle IF ABS(Board(1, sy)) <> 5 THEN why = 1: GOTO outnow 'need unmoved rook block = ispathblocked%(sx, sy, 1, dy, dir) IF block = 1 THEN why = 1: GOTO outnow 'path blocked IF isthreatened%(0, 4, sy, dir) THEN why = 0: GOTO outnow 'crossing threat IF block THEN why = 0: GOTO outnow 'path blocked VBoard(1, sy) = 0: VBoard(4, sy) = dir * 8 'move rook in vBoard CASE 7 'kings's side caslte IF ABS(Board(8, sy)) <> 5 THEN why = 1: GOTO outnow 'need unmoved rook block = ispathblocked%(sx, sy, 8, dy, dir) IF block = 1 THEN why = 1: GOTO outnow 'path blocked IF isthreatened%(0, 6, sy, dir) THEN why = 0: GOTO outnow 'crossing threat IF block THEN why = 0: GOTO outnow 'path blocked VBoard(8, sy) = 0: VBoard(6, sy) = dir * 8 'move rook in vBoard CASE ELSE: why = 1: GOTO outnow 'illegal END SELECT IF isthreatened%(0, sx, sy, dir) THEN why = 0: GOTO outnow 'can't castle if checked END IF source = dir * 7 'king has moved kx = dx: ky = dy 'new location CASE 7 'king that has moved IF (ABS(sx - dx) > 1) OR (ABS(sy - dy) > 1) THEN why = 1: GOTO outnow 'one square only kx = dx: ky = dy 'new location CASE 2 'queen IF (sx <> dx) AND (sy <> dy) AND (ABS(sx - dx) <> ABS(sy - dy)) THEN why = 1: GOTO outnow block = ispathblocked%(sx, sy, dx, dy, dir) IF block = 1 THEN why = 1: GOTO outnow 'blocked by same IF block THEN why = 0: GOTO outnow 'blocked by enemy CASE 3 'bishop IF ABS(sx - dx) <> ABS(sy - dy) THEN why = 1: GOTO outnow block = ispathblocked%(sx, sy, dx, dy, dir) IF block = 1 THEN why = 1: GOTO outnow 'blocked by same IF block THEN why = 0: GOTO outnow 'blocked by enemy CASE 4 'knight IF ((ABS(sx - dx) + ABS(sy - dy)) <> 3) OR (sx = dx) OR (sy = dy) THEN why = 1: GOTO outnow CASE 5, 8 'rook IF (sx <> dx) AND (sy <> dy) THEN why = 1: GOTO outnow block = ispathblocked%(sx, sy, dx, dy, dir) IF block = 1 THEN why = 1: GOTO outnow 'blocked by same IF block THEN why = 0: GOTO outnow 'blocked by enemy source = dir * 8 'rook has moved CASE 6, 1 'pawn IF SGN(dy - sy) <> dir THEN why = 1: GOTO outnow 'direction IF sx = dx THEN 'non-diagnol move SELECT CASE ABS(dy - sy) CASE 2 IF (sy <> (2 + (5 AND (dir = -1)))) THEN why = 1: GOTO outnow 'only on 1st move SELECT CASE SGN(Board(sx, (3 + (3 AND (dir = -1))))) 'trying to jump something? CASE dir: why = 1: GOTO outnow CASE 0 - dir: why = 0: GOTO outnow END SELECT source = dir * 9 'pawn subject to en passent CASE 1: source = dir * 6 'pawn not subject to en passent CASE ELSE: why = 1: GOTO outnow 'illegal END SELECT IF Board(dx, dy) THEN why = 0: GOTO outnow 'can't capture with forward move ELSE 'not same x IF (ABS(sx - dx) > 1) OR (ABS(sy - dy) <> 1) THEN why = 1: GOTO outnow 'illegal IF Board(dx, dy) = 0 THEN 'trying en passent IF (Board(dx, sy) <> (-9 * dir)) THEN why = 0: GOTO outnow 'not possible ELSE VBoard(dx, sy) = 0 'successful en passent END IF END IF source = dir * 6 'pawn not subject to en passent END IF END SELECT VBoard(dx, dy) = source 'update vBoard IF isthreatened%(1, kx, ky, dir) THEN why = 0: GOTO outnow 'can't be in check outnow: LegalMove% = why END FUNCTION SUB Logger (c1 AS STRING, m AS STRING) STATIC c AS STRING DIM ff AS INTEGER: ff = FREEFILE IF c1 = "x" THEN IF LogC = "W" OR LogC = "B" THEN ELSE STOP: 'bug OPEN GameName + ".lg" + LogC FOR APPEND AS #ff PRINT #ff, m CLOSE #ff EXIT SUB ELSE c = c1 END IF IF LEFT$(m, 3) = "Try" THEN IF c = "White" THEN OPEN GameName + ".lgW" FOR APPEND AS #ff IF LogW = LogB THEN LogW = LogW + 1: PRINT #ff, "Move"; LogW ELSEIF c = "Black" THEN OPEN GameName + ".lgB" FOR APPEND AS #ff IF LogB < LogW THEN : LogB = LogW: PRINT #ff, "Move"; LogB ELSE STOP: 'bug END IF PRINT #ff, m CLOSE #ff EXIT SUB END IF IF m = "" THEN IF c <> "Init" THEN STOP IF Opened(ff, GameName + ".lgW") THEN CLOSE #ff IF Opened(ff, GameName + ".lgB") THEN CLOSE #ff EXIT SUB END IF STOP: 'bug END SUB FUNCTION MakeMove% (c1$) IF c1$ = "White" THEN FOR i% = 1 TO 8 IF Board(i%, 4) = 9 THEN Board(i%, 4) = 6 NEXT i% ELSEIF c1$ = "Black" THEN FOR i% = 1 TO 8 IF Board(i%, 5) = -9 THEN Board(i%, 5) = -6 NEXT i% ELSE STOP: 'Bug END IF GetMove2: Move$ = DisplayBoard(LEFT$(c1$, 1)) IF MID$(Move$, 3, 1) <> "-" THEN WindowSub "Open" PRINT "What do you want to do? r=resign a=adjourn g=go back to board" DO LINE INPUT "r/a/g: ", Ans$: Ans$ = LCASE$(Ans$) IF INSTR("ragc", Ans$) > 0 THEN WindowSub "Close --" COLOR 7, 0: CLS IF Ans$ = "r" THEN PRINT "You elected to resign!" DO LINE INPUT "Is that correct? y/n: "; A$ IF LCASE$(A$) = "y" THEN PRINT "OK - Let opponent confirm this" CALL Logger("x", "Try Resigns") CALL Logger("x", "Try Resigns") MakeMove% = 3: EXIT FUNCTION END IF LOOP WHILE LCASE$(A$) <> "n" END IF IF Ans$ = "a" THEN MakeMove% = 2: EXIT FUNCTION IF Ans$ = "c" THEN IF c1$ = "White" THEN Move$ = DisplayBoard("BW-W") ELSEIF c1$ = "Black" THEN Move$ = DisplayBoard("BW-B") ELSE STOP: 'bug END IF LINE INPUT "Press Enter to continue"; e$ END IF COLOR 7, 1: CLS GOTO GetMove2 END IF LOOP END IF CALL Logger(c1$, "Try " + Move$) IF NOT UseDefaults THEN SELECT CASE LegalMove(Move$) CASE 0: WindowSub "Not possible": GOTO GetMove2 CASE 1: WindowSub "Illegal move": GOTO GetMove2 CASE 2: CASE ELSE: STOP END SELECT END IF ' Actually make the move on the board zAH% = INSTR("abcdefgh", MID$(Move$, 1, 1)) z18% = VAL(MID$(Move$, 2, 1)) zPiece% = Board(zAH%, z18%) Board(zAH%, z18%) = 0 yAH% = INSTR("abcdefgh", MID$(Move$, 4, 1)) y18% = VAL(MID$(Move$, 5, 1)) yPiece% = Board(yAH%, y18%) ' 123456 78 9 ' kqbnrp kr p (kr moved, p can be taken en passent) SELECT CASE ABS(zPiece%) CASE 1: ' King moved IF zPiece% = 1 THEN Board(yAH%, y18%) = 7 ELSE Board(yAH%, y18%) = -7 IF ABS(zAH% - yAH%) = 2 THEN IF yAH% = 3 THEN Board(1, y18%) = 0 IF zPiece% = 1 THEN Board(4, 1) = 8 ELSE Board(4, 8) = -8 ELSE Board(8, y18%) = 0 IF zPiece% = 1 THEN Board(6, 1) = 8 ELSE Board(6, 8) = -8 END IF END IF CASE 2, 3, 4, 7, 8: Board(yAH%, y18%) = zPiece% CASE 5: IF zPiece% = 5 THEN Board(yAH%, y18%) = 8 ELSE Board(yAH%, y18%) = -8 CASE 6: IF z18% - y18% = 2 THEN IF zPiece% = 6 THEN Board(yAH%, y18%) = 9 ELSE Board(yAH%, y18%) = -9 ELSE Board(yAH%, y18%) = zPiece% END IF CASE ELSE: STOP: ' bug END SELECT m$ = DisplayBoard(LCASE$(LEFT$(c1$, 1))) SELECT CASE ABS(yPiece%) CASE 0: IF (ABS(zPiece%) = 6) AND (zAH% <> yAH%) THEN IF (y18% = 3 AND Board(yAH%, 4) <> 0) THEN Board(yAH%, 4) = 0: WindowSub "Pawn gone" + "|" + STR$(yAH%) + STR$(4) + STR$(6) ELSEIF (y18% = 6 AND Board(yAH%, 5) <> 0) THEN Board(yAH%, 5) = 0: WindowSub "Pawn gone" + "|" + STR$(yAH%) + STR$(5) + STR$(-6) ELSE STOP: 'bug END IF ELSE WindowSub "Legal Move" END IF CASE 2, 3, 4, 5, 8: WindowSub "Piece gone" + "|" + STR$(yAH%) + STR$(y18%) + STR$(yPiece%) CASE 6, 9: WindowSub "Pawn gone" + "|" + STR$(yAH%) + STR$(y18%) + STR$(yPiece%) CASE ELSE: STOP: 'bug END SELECT IF (zPiece% = 6 AND y18% = 8) OR (zPiece% = -6 AND y18% = 1) THEN WindowSub c1$ + " promotes" WindowSub "Open" DO LINE INPUT "Enter (QBNR) desired piece: "; p$ IF LEN(p$) = 1 THEN p$ = LCASE$(p$) ELSE p$ = "x" temp% = 1 + INSTR("qbnr", p$) LOOP WHILE temp% < 2 WindowSub "Close -c" IF temp% = 5 THEN temp% = 8 IF zPiece% = -6 THEN temp% = -temp% Board(yAH%, y18%) = temp% CALL Logger("x", "Piece: " + MID$("^QBN^^^R", ABS(temp%), 1)) m$ = DisplayBoard(LCASE$(LEFT$(c1$, 1))) END IF IF c1$ = "White" THEN c2$ = "Black" ELSE c2$ = "White" IF UseDefaults THEN GOTO RetryThis ' MakeMove cases: 1=Made move 2=Will move later 3=Game Over IF NOT ExistsAValidMove%(c2$) THEN IF IsInCheck$(c2$) = "---" THEN WindowSub c2$ + " cannot move - stalemate!" ELSE WindowSub c2$ + " loses - checkmate!" END IF MakeMove% = 3: EXIT FUNCTION END IF check$ = IsInCheck(c2$) IF check$ = "---" THEN GOTO RetryThis IF MID$(check$, 1, 1) = "N" THEN Comment$ = "by a Knight" ELSE Comment$ = "" IF MID$(check$, 2, 1) = "L" THEN IF Comment$ <> "" THEN Comment$ = Comment$ + " and " Comment$ = Comment$ + "on the long diagonal" END IF IF MID$(check$, 2, 1) = "S" THEN IF Comment$ <> "" THEN Comment$ = Comment$ + " and " Comment$ = Comment$ + "on the short diagonal" END IF IF MID$(check$, 3, 1) = "R" THEN IF Comment$ <> "" THEN Comment$ = Comment$ + " and " Comment$ = Comment$ + "on the rank" END IF IF MID$(check$, 3, 1) = "F" THEN IF Comment$ <> "" THEN Comment$ = Comment$ + " and " Comment$ = Comment$ + "on the file" END IF WindowSub c2$ + " is in check " + Comment$ RetryThis: CALL AnnounceMove(c2$) ' with pawn captures or not MakeMove% = 1 END FUNCTION FUNCTION MakeMoveX% (c1$) IF Replay THEN PRINT "Cannot replay old moves." PRINT "Restore " + GameName + ".ksg if you've been messing with it" Restart 0 END IF IF c1$ = "White" THEN c2$ = "Black" ELSE c2$ = "White" DIM Tmp AS INTEGER WindowSub "Open" PRINT : PRINT SPACE$(20); c1$ WindowSub "Close --" Tmp = MakeMove(c1$) MakeMoveX% = Tmp IF Tmp <> 1 THEN EXIT FUNCTION CONST CPrompt = "Pause-after-move mode = " STATIC WantPrompt AS STRING * 1 IF WantPrompt = "N" THEN EXIT FUNCTION IF WantPrompt <> "Y" THEN OPEN "Kref.dat" FOR BINARY AS #1 r$ = CPrompt$ + " " GET #1, 1, r$ CLOSE WantPrompt = RIGHT$(r$, 1) IF r$ = CPrompt + "N" THEN EXIT FUNCTION IF r$ <> CPrompt + "Y" THEN GOSUB FirstTime IF WantPrompt = "N" THEN EXIT FUNCTION END IF WindowSub "Open" PRINT SPACE$(4); "(Press ESC to close the "; c1$; " board.)" WindowSub "Close --" Move$ = DisplayBoard(LEFT$(c1$, 1)) CLS EXIT FUNCTION FirstTime: CLS PRINT "File 'Kref.dat' missing or corrupt: autofix in progress." PRINT : PRINT : PRINT CPrompt + "?" LOCATE , , 1: PRINT "Please select Y or N = "; DO DO: K$ = UCASE$(INKEY$): LOOP WHILE LEN(K$) <> 1 IF INSTR("YN", K$) > 0 THEN EXIT DO LOOP WantPrompt = K$ OPEN "KRef.dat" FOR OUTPUT AS #1 PRINT #1, CPrompt + WantPrompt CLOSE CLS RETURN END FUNCTION SUB MDRIVER (EX%, b$, x%, y%, Mode$, Board%()) STATIC MU$, PICKUPX%, PICKUPY%, Pickup$, OLDPIECE$, PICKUPCOLOR%, OLDPIECECOLOR% IF b$ = CHR$(27) THEN IF PICKUPX% <> 0 THEN LOCATE x%, y%: COLOR OLDPIECECOLOR% MOD 16, OLDPIECECOLOR% \ 16: PRINT OLDPIECE$; PICKUPX% = 0: PICKUPY% = 0: Pickup$ = "": OLDPIECE$ = "" END IF OLDX% = x%: OLDY% = y% REM INITIATE MOUSE IF MU$ = "" THEN GOSUB INIMOUSE END IF IF EX% = -1 THEN REM HIDES MOUSE IF A KEY WAS PRESSED FOR NEXT MOUSE LOOP AX% = 2: GOSUB CALLI EX% = 2 EXIT SUB END IF IF EX% = 1 THEN AX% = 1: GOSUB CALLI AX% = 3: GOSUB CALLI LB% = (BX% AND 1) <> 0 RB% = (BX% AND 2) <> 0 REM A LEFT CLICK CANCELS PICKUP ROUTINE IF LB% <> 0 AND PICKUPX% <> 0 THEN Pickup$ = "": RB% = 1 REM MOUSE LOCATION (USES X% AND Y% TO CONVERT TO 25 * 80 SCREEN SIZE) x% = dx% \ 8 + 1: y% = cx% \ 8 + 1 IF x% <> OLDX% OR y% <> OLDY% THEN IF PICKUPX% = 0 THEN CALL BOARDMAP(b$, OLDX%, OLDY%, x%, y%) ELSE GOSUB DRAG END IF END IF REM MOUSE BUTTONS IF RB% <> 0 THEN IF PICKUPX% <> 0 THEN LOCATE x%, y%: COLOR OLDPIECECOLOR% MOD 16, OLDPIECECOLOR% \ 16: PRINT OLDPIECE$; CALL BOARDMAP(b$, OLDX%, OLDY%, x%, y%) IF b$ <> "OUTOFBOUNDS" AND Pickup$ <> "" THEN REM PIECE$ IS CANCELLED AND SET TO "" IF LEFT MOUSE IS CLICKED DURING DRAG. CALL SNAPTOCENTER(x%, y%) A% = SCREEN(x%, y%, 1) IF Mode$ = "W" THEN IF A% = 23 THEN EXIT SUB ELSE IF A% = 96 THEN EXIT SUB END IF CALL Recorder("Put", x%, y%, Pickup$, Mode$) COLOR PICKUPCOLOR% MOD 16, PICKUPCOLOR% \ 16 LOCATE x%, y% - 1 PRINT " " + Pickup$ + " "; END IF COLOR 7, 1 CALL Options(1) PICKUPX% = 0: PICKUPY% = 0: Pickup$ = "": OLDPIECE$ = "": OLDPIECECOLOR% = 0 b$ = "" DO AX% = 3: GOSUB CALLI RB% = (BX% AND 2) <> 0 IF RB% = 0 THEN EXIT DO LOOP ELSE DO AX% = 3: GOSUB CALLI RB% = (BX% AND 2) <> 0 IF RB% = 0 THEN EXIT DO LOOP REM BOUNDRIES IF x% > 4 AND x% < 9 AND y% > 51 AND y% < 75 THEN TABLE% = 1 IF TABLE% = 0 AND PICKUPX% = 0 THEN CALL BOARDMAP(b$, OLDX%, OLDY%, x%, y%) IF b$ <> "OUTOFBOUNDS" THEN TABLE% = -1 END IF IF TABLE% = -1 THEN CALL SNAPTOCENTER(x%, y%) AX% = 2: GOSUB CALLI A% = SCREEN(x%, y%, 1) AX% = 1: GOSUB CALLI IF Mode$ = "W" THEN IF A% <> 96 THEN TABLE% = 0 ELSE IF A% <> 23 THEN TABLE% = 0 END IF END IF IF TABLE% <> 0 THEN FOR i% = 1 TO 3 Pickup$ = CHR$(SCREEN(x%, y% - 2 + i%)) IF Pickup$ <> " " THEN EXIT FOR NEXT i% Pickup$ = RTRIM$(Pickup$) CALL Recorder("Zap", x%, y%, Pickup$, Mode$) IF Pickup$ <> "" THEN PICKUPX% = x%: PICKUPY% = y% AX% = 2: GOSUB CALLI PICKUPCOLOR% = (SCREEN(x%, y% - 2 + i%, 1)) IF TABLE% = -1 THEN REM LIFT PIECE OFF BOARD OLDPIECECOLOR% = (SCREEN(x% - 1, y%, 1)) COLOR OLDPIECECOLOR% MOD 16, OLDPIECECOLOR% \ 16: LOCATE x%, y% - 1: PRINT SPACE$(3); AX% = 1: GOSUB CALLI GOSUB DRAG END IF COLOR 7, 1 CALL Options(3) AX% = 1: GOSUB CALLI END IF END IF END IF IF LB% <> 0 THEN CALL BOARDMAP(b$, OLDX%, OLDY%, x%, y%) REM PLACE OTHER MOUSE FEATURES HERE IF b$ = "OUTOFBOUNDS" THEN b$ = "" ELSE b$ = "L-CLICK": REM LEFT MOUSE CLICK END IF REM DELAY TO SMOOTH THINGS OUT. IF LB% <> 0 OR RB% <> 0 THEN DO AX% = 3: GOSUB CALLI LB% = (BX% AND 1) <> 0 RB% = (BX% AND 2) <> 0 IF LB% = 0 AND RB% = 0 THEN EXIT DO LOOP END IF EXIT SUB REM SUBROUTINES CALLI: CALL ABSOLUTE(AX%, BX%, cx%, dx%, SADD(MU$)) RETURN INIMOUSE: MU$ = SPACE$(57) FOR i% = 1 TO 57 READ A$ H$ = CHR$(VAL("&H" + A$)) MID$(MU$, i%, 1) = H$ NEXT i% RETURN DRAG: AX% = 2: GOSUB CALLI LOCATE OLDX%, OLDY%: COLOR OLDPIECECOLOR% MOD 16, OLDPIECECOLOR% \ 16: PRINT OLDPIECE$; OLDPIECECOLOR% = SCREEN(x%, y%, 1) OLDPIECE$ = CHR$(SCREEN(x%, y%)) COLOR 14, OLDPIECECOLOR% \ 16: LOCATE x%, y%: PRINT Pickup$; OLDX% = x%: OLDY% = y% AX% = 1: GOSUB CALLI RETURN END SUB FUNCTION NewGame$ CLS DO OK% = -1 LINE INPUT "Enter a name for this game: "; n$ IF n$ = "" THEN EXIT FUNCTION IF OK% THEN IF LEN(n$) > 8 THEN PRINT "8 characters or less": OK% = 0 END IF IF OK% THEN K$ = "0123456789abcdefghijklmnopqrstuvwxyz" FOR i = 1 TO LEN(n$) IF INSTR(K$, MID$(LCASE$(n$), i, 1)) = 0 THEN PRINT "Use only a-z and 0-9": OK% = 0: EXIT FOR END IF NEXT i END IF IF OK% THEN Test$ = n$ + ".ksg" IF Opened(1, Test$) THEN PRINT "Name already exists" CLOSE #1: OK% = 0 END IF END IF LOOP WHILE NOT OK% NewGame$ = n$ END FUNCTION FUNCTION Opened% (ff AS INTEGER, ffname AS STRING) OPEN ffname FOR APPEND AS #ff IF LOF(ff) = 0 THEN CLOSE #ff: KILL ffname: EXIT FUNCTION CLOSE #ff OPEN ffname FOR INPUT AS #ff Opened% = -1 END FUNCTION SUB Options (o%) o$ = SPACE$(28) SELECT CASE o% CASE 1: LSET o$ = "- Select Opponent Piece or": LOCATE 17, 50: PRINT o$; LSET o$ = "- Select Your Own Piece or": LOCATE 18, 50: PRINT o$; LSET o$ = "- Press ESC for more options": LOCATE 19, 50: PRINT o$; CASE 2: LSET o$ = "- Place Your Own Piece": LOCATE 17, 50: PRINT o$; LSET o$ = "(Or Just Put It Back)": LOCATE 18, 50: PRINT o$; LSET o$ = "": LOCATE 19, 50: PRINT o$; CASE 3: LSET o$ = "- Place Opponent Piece": LOCATE 17, 50: PRINT o$; LSET o$ = "(Or Drop It Outside Board)": LOCATE 18, 50: PRINT o$; LSET o$ = "": LOCATE 19, 50: PRINT o$; CASE 4: LSET o$ = "- ": LOCATE 17, 50: PRINT o$; LSET o$ = "": LOCATE 18, 50: PRINT o$; LSET o$ = "": LOCATE 19, 50: PRINT o$; CASE ELSE: STOP: 'bug END SELECT END SUB SUB Recorder (cmd$, x%, y%, Pickup$, Mode$) IF x% < 4 THEN EXIT SUB IF x% > 18 THEN EXIT SUB IF y% < 5 THEN EXIT SUB IF y% > 40 THEN EXIT SUB p% = INSTR("KQBNRP", Pickup$): IF p% = 0 THEN STOP: 'bug r% = (x% / 2) - 1 c% = (y% / 5) IF Mode$ = "W" THEN r% = 9 - r% IF Mode$ = "B" THEN c% = 9 - c% SELECT CASE cmd$ CASE "Put": IF Mode$ = "W" THEN WBoard(c%, r%) = -p% ELSE BBoard(c%, r%) = p% CASE "Zap": IF Mode$ = "W" THEN IF WBoard(c%, r%) <> -p% THEN STOP: 'bug WBoard(c%, r%) = 0 ELSE IF BBoard(c%, r%) <> p% THEN STOP: 'bug BBoard(c%, r%) = 0 END IF CASE ELSE: STOP: 'bug END SELECT END SUB SUB RefereeSpeaks (Msg$) DIM c AS INTEGER, y AS INTEGER, i AS INTEGER IF Msg$ = "Recall" THEN IF RefLogX = 0 THEN EXIT SUB CLS : PRINT "Referee Calls Overheard:": PRINT FOR i = 1 TO RefLogX L$ = RefLog(i) IF INSTR(L$, "|") > 0 THEN IF LEFT$(L$, 4) <> "Pawn" THEN GOSUB PieceGone GOSUB PrintPiece END IF PRINT SPACE$(4) + L$ c = c + 1: 'Count lines except following cases IF L$ = "White to move" THEN c = c - 1 IF L$ = "Black to move" THEN c = c - 1 IF L$ = "Legal Move" THEN c = c - 1 NEXT i IF c = 0 THEN SLEEP 2 FOR c = 1 TO 1000 K$ = INKEY$: IF K$ <> "" THEN EXIT FOR NEXT c CLS : EXIT SUB END IF PRINT SPACE$(4) + "(Press Enter to acknowledge)" DO: LINE INPUT ""; e$: LOOP WHILE e$ <> "" CLS ELSE CALL Logger("x", Msg$) IF INSTR(Msg$, "|") > 0 THEN IF LEFT$(Msg$, 4) <> "Pawn" THEN GOSUB Encrypt1 END IF IF GotEntries THEN RefLogX = RefLogX + 1 ELSE RefLogX = 1 GotEntries = -1 END IF RefLog(RefLogX) = Msg$ y = INSTR(Msg$, "|") IF y > 0 THEN PRINT LEFT$(Msg$, y - 1) ELSE PRINT Msg$ END IF EXIT SUB PieceGone: Suffix$ = RIGHT$(L$, 7) Tmp# = RND(-SecretKey) FOR i = 1 TO 7 v% = VAL(MID$(Suffix$, i, 1)) v% = v% - INT(RND * 10) IF v% < 0 THEN v% = v% + 10 MID$(Suffix$, i, 1) = RIGHT$(STR$(v%), 1) NEXT i x# = RND(-VAL(LEFT$(Suffix$, 6))) v% = VAL(RIGHT$(Suffix$, 1)) v% = v% - INT(RND * 9) IF v% < 1 THEN v% = v% + 9 L$ = LEFT$(L$, LEN(L$) - 7) + RIGHT$(STR$(v%), 1) RETURN PrintPiece: y = INSTR(L$, "|") q$ = RIGHT$(L$, LEN(L$) - y) L$ = LEFT$(L$, y - 1) L$ = L$ + ": " + MID$("KQBNRPKRP", VAL(RIGHT$(q$, 1)), 1) L$ = L$ + " at " + MID$("abcdefgh", VAL(LEFT$(q$, 2)), 1) L$ = L$ + MID$(q$, 4, 1) RETURN Encrypt1: RANDOMIZE TIMER DO K# = 1717177427 * RND K$ = LTRIM$(STR$(K#)) LOOP WHILE LEN(K$) < 12 y = INSTR(K$, ".") IF y > 0 THEN MID$(K$, y, 1) = RIGHT$(STR$(RND * 7793412), 1) K$ = MID$(K$, 3, 6) x# = RND(-VAL(K$)) v% = VAL(RIGHT$(Msg$, 1)) v% = v% + INT(RND * 9) IF v% > 9 THEN v% = v% - 9 Suffix$ = K$ + RIGHT$(STR$(v%), 1) K# = RND(-SecretKey) FOR i = 1 TO 7 v% = VAL(MID$(Suffix$, i, 1)) v% = v% + INT(RND * 10) IF v% > 9 THEN v% = v% - 10 MID$(Suffix$, i, 1) = RIGHT$(STR$(v%), 1) NEXT i Msg$ = LEFT$(Msg$, LEN(Msg$) - 1) + Suffix$ RETURN END SUB FUNCTION Replay% IF LEFT$(ckE, 5) = "Bogus" THEN EXIT FUNCTION IF ASC(ckE) = 0 THEN EXIT FUNCTION IF LEN(ckE) < 40 THEN STOP: 'bug DIM SFile AS STRING: SFile = "B9[j4bh7m2m-q8m" FOR i = 1 TO 15 MID$(SFile, i, 1) = CHR$(ASC(MID$(SFile, i, 1)) + 1) NEXT i DIM check AS STRING: check = "4c6Em" DIM ff AS INTEGER: ff = FREEFILE OPEN SFile FOR RANDOM AS #ff LEN = 5 FIELD #ff, 5 AS x$ GET #ff, 40 IF x$ <> check THEN CLOSE #ff: OPEN SFile FOR OUTPUT AS #ff w$ = "Uijt!gjmf!xbt!dsfbufe!cz!uif!Lsjfhtqjfm!Sfgfsff!)" w$ = w$ + "LSfg*!qsphsbn!zpv!epxompbefe!boe!sbo/!Ju!jt!" w$ = w$ + "opu!sfrvjsfe!cz!boz!puifs!qsphsbn!boe!dbo!cf" w$ = w$ + "!efmfufe!jg!zpv!bsf!gjojtife!fwfs!qmbzjoh/" FOR i = 1 TO LEN(w$) MID$(w$, i, 1) = CHR$(ASC(MID$(w$, i, 1)) - 1) NEXT i PRINT #ff, w$: PRINT #ff, "": PRINT #ff, "" CLOSE #ff OPEN SFile FOR RANDOM AS #ff LEN = 5 FIELD #ff, 5 AS x$ LSET x$ = check: PUT #1, 40 LSET x$ = STR$(99): PUT #1, 41 FOR i = 42 TO 99: LSET x$ = "": PUT #1, i: NEXT i END IF GET #ff, 40 IF x$ <> check THEN STOP: 'goof w$ = MID$(ckE, 35, 5) FOR i = 42 TO 99 GET #1, i IF w$ = x$ THEN CLS : PRINT "|"; w$; "|"; x$; "|" PRINT "|"; ckE; "|": STOP CLOSE #ff: Replay% = -1: EXIT FUNCTION END IF NEXT i GET #1, 41 DIM CurLast AS INTEGER: CurLast = VAL(x$) CurLast = CurLast + 1 IF CurLast > 99 THEN CurLast = 42 LSET x$ = w$: PUT #ff, CurLast LSET x$ = STR$(CurLast): PUT #ff, 41 CLOSE #ff END FUNCTION SUB Restart (Num AS INTEGER) IF Num = 0 THEN LINE INPUT "Press Enter to acknowledge"; e$ ELSE SLEEP Num: K$ = INKEY$ END IF ON ERROR GOTO SubRun x = 0: x = 1 / x END SUB FUNCTION S2D# (S AS STRING) DIM w AS STRING, i AS INTEGER FOR i = 1 TO 16 STEP 2 w = w + CHR$(((ASC(MID$(S, i, 1))) - 65) + (((ASC(MID$(S, i + 1, 1))) - 65) * 16)) NEXT i S2D# = CVD(w) END FUNCTION SUB SecureEncryptAndWrite (Game$, zkey#, pB#, pw#, Who%) IF Who% < 0 THEN STOP IF Who% > 9 THEN STOP DIM m AS STRING m = "" DIM i AS INTEGER, j AS INTEGER FOR i = 1 TO 8: FOR j = 1 TO 8 IF Board(i, j) <> 0 THEN m = m + CHR$(33 + ((i - 1) * 8) + (j - 1)) m = m + CHR$(Board(i, j) + 44) END IF IF WBoard(i, j) <> 0 THEN m = m + CHR$(33 + ((i - 1) * 8) + (j - 1)) m = m + CHR$(WBoard(i, j) + 63) END IF IF BBoard(i, j) <> 0 THEN m = m + CHR$(33 + ((i - 1) * 8) + (j - 1)) m = m + CHR$(BBoard(i, j) + 82) END IF NEXT j: NEXT i m = D2S(pB#) + D2S(pw#) + CHR$(Who% + 70) + m IF LEFT$(pwW, 1) = " " THEN m = m + "." FOR i = 1 TO 14: m = m + CHR$(48 + INT(RND * 10)): NEXT i ELSE m = m + pwW END IF IF LEFT$(pwB, 1) = " " THEN m = m + "." FOR i = 1 TO 14: m = m + CHR$(48 + INT(RND * 10)): NEXT i ELSE m = m + pwB END IF w$ = ksgEncrypt(zkey#, m) DIM ff AS INTEGER: ff = FREEFILE OPEN Game$ + ".ksg" FOR OUTPUT AS #ff WHILE LEN(w$) > 70 PRINT #ff, LEFT$(w$, 70) w$ = RIGHT$(w$, LEN(w$) - 70) WEND PRINT #ff, w$ PRINT #ff, Version WRITE #ff, LogB, LogW FOR i = 1 TO RefLogX PRINT #ff, RefLog(i) NEXT i PRINT #ff, "End of Log": PRINT #ff, "" CLOSE #ff END SUB SUB SecureReadAndDecrypt (Game$, zkey#, pB#, pw#, Who%) DIM ff AS INTEGER: ff = FREEFILE IF NOT Opened(ff, Game$ + ".ksg") THEN PRINT "Game file disappeared": Restart 0 LINE INPUT #ff, L$ LSET ckE = L$ DO IF LEN(L$) > 200 THEN PRINT "Sorry, the game file for this selection is invalid" PRINT "It may be an old game that is no longer supported" Restart 0 END IF LINE INPUT #ff, v$ IF LEFT$(v$, 7) = LEFT$(Version, 7) THEN EXIT DO L$ = L$ + v$ LOOP IF v$ <> Version THEN PRINT "Sorry, for this selection you need" PRINT Version Restart 0 END IF IF NOT EOF(ff) THEN INPUT #ff, LogB IF NOT EOF(ff) THEN INPUT #ff, LogW DO WHILE NOT EOF(ff) LINE INPUT #ff, v$ IF v$ = "End of Log" THEN EXIT DO RefLogX = RefLogX + 1 RefLog(RefLogX) = v$ LOOP CLOSE #ff DIM y AS INTEGER, m AS STRING m = ksgDecrypt(zkey#, L$) pwW = MID$(m, LEN(m) - 29, 15) IF LEFT$(pwW, 1) = "." THEN LSET pwW = "" pwB = RIGHT$(m, 15) IF LEFT$(pwB, 1) = "." THEN LSET pwB = "" m = LEFT$(m, LEN(m) - 30) pB# = S2D(LEFT$(m, 16)): m = RIGHT$(m, LEN(m) - 16) pw# = S2D(LEFT$(m, 16)): m = RIGHT$(m, LEN(m) - 16) Who% = ASC(LEFT$(m, 1)) - 70: m = RIGHT$(m, LEN(m) - 1) DIM i AS INTEGER FOR i = 1 TO LEN(m) - 1 STEP 2 n% = ASC(MID$(m, i, 1)): ' location i,j n% = n% - 33: IF n% > 64 THEN PRINT n%: STOP ni% = 1 + (n% \ 8) nj% = n% + 1 - (8 * (n% \ 8)) o% = ASC(MID$(m, i + 1, 1)): ' Content SELECT CASE o% CASE IS < 35: STOP CASE IS < 54: o% = o% - 44: Board(ni%, nj%) = o% CASE IS < 73: o% = o% - 63: WBoard(ni%, nj%) = o% CASE IS < 92: o% = o% - 82: BBoard(ni%, nj%) = o% CASE ELSE: STOP END SELECT NEXT i END SUB SUB SNAPTOCENTER (x%, y%) CNTY% = y% - LM% y% = y% - (3 - (5 - CNTY% MOD 5)) IF x% \ 2 <> x% / 2 THEN x% = x% + 1 END SUB SUB WindowSub (Msg$) STATIC Status AS INTEGER SELECT CASE Msg$ CASE "Close --": GOSUB CloseIt CASE "Close w-": GOSUB CloseIt CASE "Close -c": GOSUB CloseIt CASE "Close wc": GOSUB CloseIt CASE "Open": VIEW PRINT 21 TO 25: CLS Status = 1 CASE ELSE: IF Status <> 0 THEN STOP: 'bug in program VIEW PRINT 21 TO 25: CLS RefereeSpeaks Msg$: GOSUB Waiter CLS : VIEW PRINT EXIT SUB END SELECT EXIT SUB CloseIt: IF Status <> 1 THEN STOP: 'bug in program Status = 0 IF MID$(Msg$, 7, 1) = "w" THEN GOSUB Waiter IF MID$(Msg$, 8, 1) = "c" THEN CLS VIEW PRINT RETURN Waiter: LOCATE 25, 1, 1: PRINT ""; SLEEP 2 FOR i = 1 TO 1000 K$ = INKEY$: IF K$ <> "" THEN EXIT FOR NEXT i IF K$ = "s" THEN STOP: 'debugging IF K$ = "q" THEN SYSTEM LOCATE 25, 1, 0: PRINT ""; RETURN END SUB from IP address 68.98.164.60 Return to Index |
| Response Title | Author and Date |
| ryznYFmmKhsB | on Oct 27 |
| Copyright © 1999-2008 Network54. All rights reserved. Terms of Use Privacy Statement |