|
|
Post by anthonyrbrown on Nov 20, 2023 15:10:27 GMT
Even though I have made other games programs using QB64 I skipped Checkers because as I said above I thought it was solved? Now it has fired up my interest to make a Checkers program with my New! {TURBO LEARN} etc.  And as a starter below is a Checkers program made by someone? called CHECKERX made in 20001 it's a starter waiting for all the latest AI techniques DEFINT A-Z
DECLARE FUNCTION BTTN ()
DECLARE FUNCTION GETKEY$ ()
DECLARE FUNCTION SELECTPIECE (FLASH)
DECLARE FUNCTION JUMPWAY (START, MIDDLE)
DECLARE FUNCTION INCREMENT (A)
DECLARE FUNCTION ISTOP (P)
DECLARE FUNCTION ISLEFT (P)
DECLARE FUNCTION ISRIGHT (P)
DECLARE FUNCTION ISBOTTOM (P)
DECLARE FUNCTION TOPLEFT (POSITION)
DECLARE FUNCTION TOPRIGHT (POSITION)
DECLARE FUNCTION BOTTOMLEFT (POSITION)
DECLARE FUNCTION BOTTOMRIGHT (POSITION)
DECLARE FUNCTION SAMEROW (P1, P2)
DECLARE FUNCTION SAMECOLUMN (P1, P2)
DECLARE FUNCTION SCAN (POSITION)
DECLARE FUNCTION JOYSTICK (FLASH)
DECLARE SUB HUMANSMOVE ()
DECLARE SUB PICKMOVE ()
DECLARE SUB DELETEBLACK (P%)
DECLARE SUB DELETERED (P)
DECLARE SUB PUTCHECKER (P, RD, KING)
DECLARE SUB ERASECHECKER (P)
DECLARE SUB COMPUTERSTURN ()
DECLARE SUB DRAWBORD ()
DECLARE SUB TESTCOMPUTERSMOVES ()
DECLARE SUB CALCULATEPOINTS ()
DECLARE SUB HUMANSMOVES ()
DECLARE SUB SCANAROUND (PIECE, COL)
DECLARE SUB PREPAREPIECES ()
DECLARE SUB ALLMOVES (PIECE, C, JUMPS)
DECLARE SUB UPDATE ()
CONST TRUE = -1, FALSE = NOT TRUE
CONST RED = 0, BLACK = 1, NULL = 2
CONST SNGL = 0, JMP = 1, KING = 2
TYPE PIECE
PST AS INTEGER
KING AS INTEGER
END TYPE
TYPE M
PCE AS INTEGER
MOVE AS INTEGER
END TYPE
TYPE CO
X AS INTEGER
Y AS INTEGER
END TYPE
CLEAR , , 5000
DIM SHARED REDS(12) AS PIECE, BLACKS(12) AS PIECE, NUMREDS, NUMBLACKS
DIM SHARED POSMAP(12, 4), POSMOVES(12), PTY(12, 4), TYP(12, 4), M(12, 4)
DIM SHARED POSMAPR(12, 4), POSMOVESR(12), TYPR(12, 4), MR(12, 4)
DIM SHARED TEMPPOS(4), TEMPNUM, TEMP(4), TEMPN, GOOD(4)
DIM SHARED PIECE, MOVE, C
DIM SHARED XY(32) AS CO, GAME
DIM SHARED K$, AA(15), AG(90), BG(90)
DIM SHARED POINTS(13) AS DOUBLE
DIM SHARED MEM(12, 12, 4), USED(12), NOTUSED(12), IN, GIVEUP
AL = 60
BL = 60
GAME = FALSE
IN = FALSE
PREPAREPIECES
SCREEN 1
COLOR 0, 0
CLS
VIEW PRINT 1 TO 25
RANDOMIZE TIMER
GET (0, 0)-(26, 18), BG()
DRAW "Bm160,100h5nd3r3"
GET (160, 100)-(160 - 5, 100 - 5), AA()
CLS
EXISTS = TRUE
ON ERROR GOTO NOTEXISTS
OPEN "I", #1, "LEARN.DAT"
ON ERROR GOTO 0
IF EXISTS THEN
FOR A = 1 TO 12
INPUT #1, POINTS(A)
NEXT
CLOSE
END IF
PRINT
PRINT "{ CHECKERX 20001 }"
PRINT "H.A.D DATA HAS ";
IF EXISTS THEN
PRINT "BEEN LOADED"
ELSE
PRINT "NOT BEEN LOADED"
END IF
PRINT "HEURISTIC APPLICATION DATA(H.A.D):"
FOR A = 1 TO 12
PRINT "RULE "; MID$(STR$(A), 2); ":"; POINTS(A)
NEXT
PRINT
PRINT "PLEASE SELECT INPUT DEVICE:"
PRINT "1. KEYBOARD"
PRINT "2. JOYSTICK"
LN = CSRLIN
DO
LOCATE LN, 1
LINE INPUT A$
A = VAL(A$)
LOOP UNTIL A = 1 OR A = 2
IF A = 2 THEN
IN = FALSE
ELSE
IN = TRUE
END IF
CLS
IF IN THEN
PRINT "KEYS TO USE:"
PRINT
PRINT "LEFT AND RIGHT ARROWS SELECT"
PRINT
PRINT "Q = QUIT"
PRINT
PRINT "T = TAKES BACK A SELECTED PIECE"
ELSE
PRINT "USE JOYSTICK(STICK 0 AND 1) TO"
PRINT "SELECT PIECES"
PRINT
PRINT "Q = QUIT"
PRINT
PRINT "T = TAKES BACK A SELECTED PIECE"
END IF
PRINT
PRINT
PRINT "NOTE: WHILE MAKING A MULTIPLE JUMP, GO"
PRINT "TO THE PLACE WHERE YOU WANT TO JUMP TO,"
PRINT "OTHERWISE, SELECT ANY ILLEGAL BLOCK IF"
PRINT "YOU DONT WANT TO JUMP."
IF IN THEN
LOCATE 24, 1
PRINT "PRESS A KEY TO PLAY";
A$ = INPUT$(1)
ELSE
LOCATE 24, 1
PRINT "CLICK JOYSTICK TO PLAY";
DO
LOOP UNTIL STRIG(1)
END IF
CLS
DRAWBORD
UPDATE
DO
COMPUTERSTURN
LOCATE 1, 12
PRINT "RED:"; NUMREDS; "BLACK:"; NUMBLACKS; " "
IF NOT GIVEUP AND NUMREDS <> 0 THEN
HUMANSMOVE
END IF
LOCATE 1, 12
PRINT "RED:"; NUMREDS; "BLACK:"; NUMBLACKS; " "
LOOP UNTIL GIVEUP OR NUMREDS = 0 OR NUMBLACKS = 0
CLS
IF GIVEUP THEN
PRINT "IT'S A TIE! WELL, HOW ABOUT THAT!"
PRINT "LEARNED DATA NOT UPDATED."
END
END IF
IF NUMBLACKS = 0 THEN
PRINT "I LOST! DARN!"
FOR A = 1 TO 12
POINTS(A) = POINTS(A) - USED(A) * 3 + NOTUSED(A)
NEXT
END IF
IF NUMREDS = 0 THEN
PRINT "I WON! GREAT!!"
END IF
PRINT "RULE USAGE STATISTICS"
PRINT "USED", "NOTUSED"
FOR A = 1 TO 12
PRINT MID$(STR$(A), 2); ":"; USED(A), NOTUSED(A)
NEXT
OPEN "O", #1, "LEARN.DAT"
FOR A = 1 TO 12
PRINT #1, POINTS(A)
NEXT
CLOSE #1
PRINT "LEARNED DATA STORED"
SOUND 2600, 22
END
NOTEXISTS:
EXISTS = FALSE
RESUME NEXT
SUB ALLMOVES (PIECE, C, JUMPS)
POSMOVES(PIECE) = 0
SCANAROUND PIECE, C
FOR A = 0 TO TEMPNUM - 1
TEMP(A) = TEMPPOS(A)
GOOD(A) = TRUE
NEXT
TEMPN = TEMPNUM
FOR A = 0 TO TEMPN - 1
P = TEMP(A)
SELECT CASE C
CASE RED
IF NOT REDS(PIECE).KING AND (INT(P / 4) * 4) > INT(REDS(PIECE).PST / 4) * 4 THEN
GOOD(A) = FALSE
END IF
IF SCAN(P) = RED THEN
GOOD(A) = FALSE
END IF
CASE BLACK
IF NOT BLACKS(PIECE).KING AND (INT(P / 4) * 4) < INT(BLACKS(PIECE).PST / 4) * 4 THEN
GOOD(A) = FALSE
END IF
IF SCAN(P) = BLACK THEN
GOOD(A) = FALSE
END IF
END SELECT
NEXT
FOR A = 0 TO TEMPN - 1
IF GOOD(A) THEN
S = SCAN(TEMP(A))
IF S = NULL AND JUMPS = FALSE THEN
POSMAP(PIECE, POSMOVES(PIECE)) = TEMP(A)
TYP(PIECE, POSMOVES(PIECE)) = SNGL
SELECT CASE C
CASE RED
IF (INT(TEMP(A) / 4) * 4) = 0 AND REDS(PIECE).KING = FALSE THEN
TYP(PIECE, POSMOVES(PIECE)) = KING
END IF
CASE BLACK
IF (INT(TEMP(A) / 4) * 4) = 28 AND BLACKS(PIECE).KING = FALSE THEN
TYP(PIECE, POSMOVES(PIECE)) = KING
END IF
END SELECT
POSMOVES(PIECE) = INCREMENT(POSMOVES(PIECE))
ELSE
IF S <> NULL THEN
IF NOT (ISTOP(TEMP(A)) OR ISBOTTOM(TEMP(A)) OR ISLEFT(TEMP(A)) OR ISRIGHT(TEMP(A))) THEN
SELECT CASE C
CASE RED
J = JUMPWAY(REDS(PIECE).PST, TEMP(A))
CASE BLACK
J = JUMPWAY(BLACKS(PIECE).PST, TEMP(A))
END SELECT
IF SCAN(J) = NULL THEN
POSMAP(PIECE, POSMOVES(PIECE)) = J
TYP(PIECE, POSMOVES(PIECE)) = JMP
M(PIECE, POSMOVES(PIECE)) = TEMP(A)
POSMOVES(PIECE) = INCREMENT(POSMOVES(PIECE))
END IF
END IF
END IF
END IF
END IF
NEXT
END SUB
FUNCTION BOTTOMLEFT (POSITION)
FIRST = INT(POSITION / 4) * 4
IF (FIRST AND 4) = 0 THEN
BOTTOMLEFT = POSITION + 4
ELSE
BOTTOMLEFT = POSITION + 3
END IF
END FUNCTION
FUNCTION BOTTOMRIGHT (POSITION)
FIRST = INT(POSITION / 4) * 4
IF (FIRST AND 4) = 0 THEN
BOTTOMRIGHT = POSITION + 5
ELSE
BOTTOMRIGHT = POSITION + 4
END IF
END FUNCTION
FUNCTION BTTN
STATIC BOUNCE
BTTN = FALSE
IF STRIG(1) THEN
IF NOT BOUNCE THEN
BOUNCE = TRUE
BTTN = TRUE
END IF
ELSE
BOUNCE = FALSE
END IF
END FUNCTION
SUB CALCULATEPOINTS
DIM POSJUMPS(60)
DIM POSKING(60)
DIM POSMAPS(12, 4), POSMOVESS(12), TYPS(12, 4), MS(12, 4)
DIM POSMAPS1(12, 4), POSMOVESS1(12), TYPS1(12, 4), MS1(12, 4)
HUMANSMOVES
TESTCOMPUTERSMOVES
GIVEUP = TRUE
FOR A = 1 TO NUMBLACKS
IF POSMOVES(A) > 0 THEN
GIVEUP = FALSE
EXIT FOR
END IF
NEXT
IF NOT GIVEUP THEN
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVES(A) - 1
FOR C = 1 TO 12
MEM(C, A, B) = FALSE
NEXT
PTY(A, B) = 0
NEXT
NEXT
POSJUMPS = 0
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVESR(A) - 1
IF TYPR(A, B) = JMP THEN
POSJUMPS(POSJUMPS) = POSMAPR(A, B)
POSJUMPS = INCREMENT(POSJUMPS)
END IF
NEXT
NEXT
POSKINGS = 0
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVESR(A) - 1
IF TYPR(A, B) = KING THEN
POSKING(POSKINGS) = POSMAPR(A, B)
POSKINGS = INCREMENT(POSKINGS)
END IF
NEXT
NEXT
FOR A = 0 TO POSJUMPS - 1
FOR B = 1 TO NUMBLACKS
FOR C = 0 TO POSMOVES(B) - 1
IF POSMAP(B, C) = POSJUMPS(A) THEN
PTY(B, C) = PTY(B, C) + POINTS(1)
MEM(1, B, C) = TRUE
END IF
NEXT
NEXT
NEXT
FOR A = 0 TO POSKINGS - 1
FOR B = 1 TO NUMBLACKS
FOR C = 0 TO POSMOVES(B) - 1
IF POSMAP(B, C) = POSKING(A) THEN
PTY(B, C) = PTY(B, C) + POINTS(2)
MEM(2, B, C) = TRUE
END IF
NEXT
NEXT
NEXT
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVES(A) - 1
SELECT CASE TYP(A, B)
CASE KING
PTY(A, B) = PTY(A, B) + POINTS(3)
MEM(3, A, B) = TRUE
CASE JMP
PTY(A, B) = PTY(A, B) + POINTS(4)
MEM(4, A, B) = TRUE
CASE SNGL
END SELECT
NEXT
NEXT
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVESR(A) - 1
IF TYPR(A, B) = JMP THEN
F = SCAN(MR(A, B))
FOR C1 = 0 TO POSMOVES(C) - 1
PTY(C, C1) = PTY(C, C1) + POINTS(6)
MEM(6, C, C1) = TRUE
NEXT
END IF
NEXT
NEXT
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVES(A) - 1
POSMAPS(A, B) = POSMAP(A, B)
TYPS(A, B) = TYP(A, B)
MS(A, B) = M(A, B)
NEXT
POSMOVESS(A) = POSMOVES(A)
NEXT
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVESR(A) - 1
POSMAPS1(A, B) = POSMAPR(A, B)
TYPS1(A, B) = TYPR(A, B)
MS1(A, B) = MR(A, B)
NEXT
POSMOVESS1(A) = POSMOVESR(A)
NEXT
FOR A1 = 1 TO NUMBLACKS
LAST = BLACKS(A1).PST
FOR B = 0 TO POSMOVESS(A1) - 1
DEST = POSMAPS(A1, B)
BLACKS(A1).PST = DEST
IF TYPS(A1, B) = JMP THEN
F = SCAN(MS(A1, B))
MCHECKER = C
MPOS = REDS(MCHECKER).PST
MKING = REDS(MCHECKER).KING
DELETERED MCHECKER
END IF
TESTCOMPUTERSMOVES
FOR D = 0 TO POSMOVES(A1) - 1
SELECT CASE TYP(A1, D)
CASE JMP
PTY(A1, D) = PTY(A1, D) + POINTS(11)
MEM(11, A1, B) = TRUE
CASE KING
PTY(A1, D) = PTY(A1, D) + POINTS(12)
MEM(12, A1, B) = TRUE
CASE SNGL
END SELECT
NEXT
HUMANSMOVES
FOR C1 = 1 TO NUMREDS
FOR D = 0 TO POSMOVESR(C1) - 1
IF TYPR(C1, D) = JMP THEN
IF POSMAPR(C1, D) = LAST THEN
PTY(A1, B) = PTY(A1, B) + POINTS(8)
MEM(8, A1, B) = TRUE
END IF
IF SCAN(MR(C1, D)) = BLACK AND C = A1 THEN
PTY(A1, B) = PTY(A1, B) + POINTS(9)
MEM(9, A1, B) = TRUE
END IF
IF POSMAPR(C1, D) = MPOS THEN
PTY(A1, B) = PTY(A1, B) + POINTS(10)
MEM(10, A1, B) = TRUE
END IF
END IF
NEXT D
NEXT C1
IF TYPS(A1, B) = JMP THEN
FOR Z = NUMREDS + 1 TO MCHECKER + 1 STEP -1
REDS(Z).PST = REDS(Z - 1).PST
REDS(Z).KING = REDS(Z - 1).KING
NEXT Z
REDS(MCHECKER).PST = MPOS
REDS(MCHECKER).KING = MKING
NUMREDS = NUMREDS + 1
END IF
BLACKS(A1).PST = LAST
NEXT B
NEXT A1
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVESS(A) - 1
SWAP POSMAPS(A, B), POSMAP(A, B)
SWAP TYPS(A, B), TYP(A, B)
SWAP MS(A, B), M(A, B)
NEXT
SWAP POSMOVESS(A), POSMOVES(A)
NEXT
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVESS1(A) - 1
SWAP POSMAPS1(A, B), POSMAPR(A, B)
SWAP TYPS1(A, B), TYPR(A, B)
SWAP MS1(A, B), MR(A, B)
NEXT
SWAP POSMOVESS1(A), POSMOVESR(A)
NEXT
END IF
END SUB
SUB COMPUTERSTURN
LOCATE 24, 14
PRINT "Thinking...";
CALCULATEPOINTS
IF NOT GIVEUP THEN
PICKMOVE
LOCATE 24, 1
PRINT SPACE$(70);
ERASECHECKER BLACKS(PIECE).PST
BLACKS(PIECE).PST = POSMAP(PIECE, MOVE)
IF NOT BLACKS(PIECE).KING AND (INT(BLACKS(PIECE).PST / 4) * 4) = 28 THEN
BLACKS(PIECE).KING = TRUE
END IF
PUTCHECKER BLACKS(PIECE).PST, FALSE, BLACKS(PIECE).KING
IF TYP(PIECE, MOVE) = JMP THEN
P = PIECE
DO
SLEEP 1
ERASECHECKER BLACKS(P).PST
T = SCAN(M(P, MOVE))
ERASECHECKER M(P, MOVE)
DELETERED C
SOUND 1000, 6
BLACKS(0).PST = POSMAP(P, MOVE)
BLACKS(0).KING = BLACKS(P).KING
PUTCHECKER BLACKS(0).PST, FALSE, BLACKS(0).KING
IF NOT BLACKS(0).KING AND (INT(BLACKS(0).PST / 4) * 4) = 28 THEN
BLACKS(0).KING = TRUE
PUTCHECKER BLACKS(0).PST, FALSE, TRUE
END IF
ALLMOVES 0, BLACK, TRUE
IF POSMOVES(0) <> 0 THEN
P = 0
MOVE = INT(RND(1) * POSMOVES(0))
PUTCHECKER BLACKS(P).PST, FALSE, BLACKS(P).KING
END IF
LOOP UNTIL POSMOVES(0) = 0
BLACKS(PIECE).PST = BLACKS(0).PST
BLACKS(PIECE).KING = BLACKS(0).KING
PUTCHECKER BLACKS(PIECE).PST, FALSE, BLACKS(PIECE).KING
IF NOT BLACKS(PIECE).KING AND (INT(BLACKS(PIECE).PST / 4) * 4) = 28 THEN
BLACKS(PIECE).KING = TRUE
PUTCHECKER BLACKS(PIECE).PST, FALSE, TRUE
END IF
END IF
END IF
END SUB
SUB DELETEBLACK (P)
FOR A = P + 1 TO NUMBLACKS
BLACKS(A - 1).PST = BLACKS(A).PST
BLACKS(A - 1).KING = BLACKS(A).KING
NEXT
NUMBLACKS = NUMBLACKS - 1
END SUB
SUB DELETERED (P)
FOR A = P + 1 TO NUMREDS
REDS(A - 1).PST = REDS(A).PST
REDS(A - 1).KING = REDS(A).KING
NEXT
NUMREDS = NUMREDS - 1
END SUB
SUB DRAWBORD
X = 0
Z = 0
FOR R = 16 TO 156 STEP 20
FOR C = 48 TO 244 STEP 28
LINE (C, R)-(C + 28, R + 20), 1, B
IF X = 0 THEN
PAINT (C + 1, R + 1), 2, 1
X = 1
ELSE
X = 0
END IF
NEXT
IF X = 0 THEN
X = 1
ELSE
X = 0
END IF
NEXT
X = 76
W = 244
Y = 16
FOR Q = 0 TO 31
XY(Q).X = X
XY(Q).Y = Y
X = X + 56
IF X > W THEN
Y = Y + 20
IF Z = 0 THEN
X = 48
W = 216
Z = 1
ELSE
Z = 0
X = 76
W = 244
END IF
END IF
NEXT
END SUB
SUB ERASECHECKER (P)
X = XY(P).X
Y = XY(P).Y
LINE (X + 1, Y + 1)-(X + 27, Y + 19), 0, BF
END SUB
FUNCTION GETKEY$
DO
K$ = INKEY$
LOOP UNTIL K$ <> ""
GETKEY$ = UCASE$(K$)
END FUNCTION
SUB HUMANSMOVE
DO
LOCATE 24, 14
PRINT "SELECT PIECE";
DO
IF IN THEN
A = SELECTPIECE(-1)
ELSE
A = JOYSTICK(-1)
END IF
IF K$ = "Q" OR K$ = "q" THEN CLS :_
END
A = SCAN(A)
IF A <> NULL THEN
C1 = C
ALLMOVES C1, RED, FALSE
END IF
LOOP WHILE A = NULL OR A <> RED OR POSMOVES(C1) = 0
LOCATE 24, 1
PRINT SPACE$(70);
LOCATE 24, 16
PRINT "To Where?"
DO
IF IN THEN
A = SELECTPIECE(REDS(C1).PST)
ELSE
A = JOYSTICK(REDS(C1).PST)
END IF
FOUND = FALSE
FOR R = 0 TO POSMOVES(C1) - 1
IF POSMAP(C1, R) = A THEN
FOUND = TRUE
EXIT FOR
END IF
NEXT
LOOP UNTIL FOUND OR K$ = "T" OR K$ = "t"
LOOP WHILE K$ = "T" OR K$ = "t"
LOCATE 24, 1
PRINT SPACE$(70);
ERASECHECKER REDS(C1).PST
REDS(C1).PST = POSMAP(C1, R)
IF NOT REDS(C1).KING AND (INT(REDS(C1).PST / 4) * 4) = 0 THEN
REDS(C1).KING = TRUE
END IF
PUTCHECKER POSMAP(C1, R), TRUE, REDS(C1).KING
IF TYP(C1, R) = JMP THEN
ERASECHECKER M(C1, R)
T = SCAN(M(C1, R))
DELETEBLACK C
SOUND 1000, 4
DO
PUTCHECKER REDS(C1).PST, TRUE, REDS(C1).KING
ALLMOVES C1, RED, TRUE
IF POSMOVES(C1) <> 0 THEN
LOCATE 24, 11
PRINT "Continue Your Jump";
IF IN THEN
A = SELECTPIECE(REDS(C1).PST)
ELSE
A = JOYSTICK(REDS(C1).PST)
END IF
FOUND = FALSE
FOR R1 = 0 TO POSMOVES(C1) - 1
IF POSMAP(C1, R1) = A THEN
FOUND = TRUE
EXIT FOR
END IF
NEXT
IF FOUND THEN
ERASECHECKER REDS(C1).PST
REDS(C1).PST = A
IF NOT REDS(C1).KING AND (INT(REDS(C1).PST / 4) * 4) = 0 THEN
REDS(C1).KING = TRUE
END IF
ERASECHECKER M(C1, R1)
T = SCAN(M(C1, R1))
DELETEBLACK C
SOUND 1000, 4
END IF
END IF
LOOP UNTIL NOT FOUND OR POSMOVES(C1) = 0
LOCATE 24, 1
PRINT SPACE$(70);
END IF
PUTCHECKER REDS(C1).PST, TRUE, REDS(C1).KING
IF NOT REDS(C1).KING AND (INT(REDS(C1).PST / 4) * 4) = 0 THEN
REDS(C1).KING = TRUE
PUTCHECKER REDS(C1).PST, TRUE, TRUE
END IF
END SUB
SUB HUMANSMOVES
FOR A = 1 TO NUMREDS
ALLMOVES A, REDS, FALSE
NEXT
FOR A = 1 TO NUMREDS
FOR B = 0 TO POSMOVES(A) - 1
POSMAPR(A, B) = POSMAP(A, B)
TYPR(A, B) = TYP(A, B)
MR(A, B) = M(A, B)
NEXT
POSMOVESR(A) = POSMOVES(A)
NEXT
END SUB
FUNCTION INCREMENT (A)
INCREMENT = A + 1
END FUNCTION
FUNCTION ISBOTTOM (P)
IF P > 27 THEN
ISBOTTOM = TRUE
ELSE
ISBOTTOM = FALSE
END IF
END FUNCTION
FUNCTION ISLEFT (P)
SELECT CASE P
CASE 4, 12, 20, 28
ISLEFT = TRUE
CASE ELSE
ISLEFT = FALSE
END SELECT
END FUNCTION
FUNCTION ISRIGHT (P)
SELECT CASE P
CASE 3, 11, 19, 27
ISRIGHT = TRUE
CASE ELSE
ISRIGHT = FALSE
END SELECT
END FUNCTION
FUNCTION ISTOP (P)
IF P < 4 THEN
ISTOP = TRUE
ELSE
ISTOP = FALSE
END IF
END FUNCTION
FUNCTION JOYSTICK (FLASH)
STATIC HIGHESTX, HIGHESTY, FIRSTTIME
STATIC AL, BL
DIM TSTART AS SINGLE
IF FIRSTTIME = 0 THEN
FIRSTTIME = -1
HIGHESTX = 1
HIGHESTY = 1
END IF
IF FLASH <> -1 THEN
GET (XY(FLASH).X, XY(FLASH).Y)-(XY(FLASH).X + 28, XY(FLASH).Y + 20), AG()
TSTART = TIMER
SWITCH = 0
END IF
DO
NEW = TRUE
PUT (AL, BL), AA()
DO
AX = STICK(0)
BX = STICK(1)
IF AX > HIGHESTX THEN
HIGHESTX = AX
END IF
IF BX > HIGHESTY THEN
HIGHESTY = BX
END IF
A2 = INT(AX * (314 / HIGHESTX))
B2 = INT(BX * (194 / HIGHESTY))
A2 = AL + (A2 - AL) / 12
B2 = BL + (B2 - BL) / 12
IF NEW OR AL <> A2 OR BL <> B2 THEN
NEW = FALSE
PUT (AL, BL), AA()
PUT (A2, B2), AA()
AL = A2
BL = B2
END IF
IF FLASH <> -1 AND TIMER - TSTART > .3 THEN
SWITCH = (SWITCH + 1) MOD 2
PUT (AL, BL), AA()
IF SWITCH = 1 THEN
PUT (XY(FLASH).X + 1, XY(FLASH).Y + 1), BG(), PSET
ELSE
PUT (XY(FLASH).X, XY(FLASH).Y), AG(), PSET
END IF
PUT (AL, BL), AA()
TSTART = TIMER
END IF
K$ = INKEY$
SELECTED = BTTN
LOOP UNTIL SELECTED OR K$ <> ""
PUT (AL, BL), AA()
IF FLASH <> -1 THEN
PUT (XY(FLASH).X, XY(FLASH).Y), AG(), PSET
END IF
IF SELECTED AND BL >= 16 AND BL <= 176 AND AL >= 48 AND AL <= 272 THEN
AM = AL - 48
BM = BL - 16
AM = INT(AM / 28) * 28
BM = INT(BM / 20) * 20
AM = AM + 48
BM = BM + 16
SOUND 200, 1
FOR A = 0 TO 31
IF XY(A).X = AM AND XY(A).Y = BM THEN
GOOD = TRUE
EXIT FOR
ELSE
GOOD = FALSE
END IF
NEXT
END IF
LOOP UNTIL GOOD OR K$ = "T" OR K$ = "t" OR K$ = "q" OR K$ = "Q" OR K$ = " " OR K$ = CHR$(13)
IF GOOD THEN
JOYSTICK = A
END IF
END FUNCTION
FUNCTION JUMPWAY (START, MIDDLE)
S = INT(START / 4) * 4
M = INT(MIDDLE / 4) * 4
IF (M AND 4) = 4 THEN
IF S < M THEN
IF ABS(MIDDLE - START) = 5 THEN
JUMPWAY = MIDDLE + 4
ELSE
JUMPWAY = MIDDLE + 3
END IF
ELSE
IF ABS(START - MIDDLE) = 4 THEN
JUMPWAY = MIDDLE - 5
ELSE
JUMPWAY = MIDDLE - 4
END IF
END IF
ELSE
IF S < M THEN
IF ABS(MIDDLE - START) = 3 THEN
JUMPWAY = MIDDLE + 4
ELSE
JUMPWAY = MIDDLE + 5
END IF
ELSE
IF ABS(START - MIDDLE) = 5 THEN
JUMPWAY = MIDDLE - 4
ELSE
JUMPWAY = MIDDLE - 3
END IF
END IF
END IF
END FUNCTION
SUB PICKMOVE
DIM PICK(60) AS M
DIM HIGHEST AS DOUBLE
PICKS = 0
HIGHEST = -32000
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVES(A) - 1
IF PTY(A, B) > HIGHEST THEN
HIGHEST = PTY(A, B)
END IF
NEXT
NEXT
FOR A = 1 TO NUMBLACKS
FOR B = 0 TO POSMOVES(A) - 1
IF PTY(A, B) = HIGHEST THEN
PICK(PICKS).PCE = A
PICK(PICKS).MOVE = B
PICKS = INCREMENT(PICKS)
END IF
NEXT
NEXT
RAND = INT(RND(1) * PICKS)
PIECE = PICK(RAND).PCE
MOVE = PICK(RAND).MOVE
FOR A = 1 TO 12
IF MEM(A, PIECE, MOVE) THEN
USED(A) = USED(A) + 1
ELSE
NOTUSED(A) = NOTUSED(A) + 1
END IF
NEXT
END SUB
SUB PREPAREPIECES
NUMREDS = 12
NUMBLACKS = 12
FOR A = 0 TO 11
BLACKS(A + 1).PST = A
BLACKS(A + 1).KING = GAME
NEXT
FOR A = 20 TO 31
REDS(A - 19).PST = A
REDS(A - 19).KING = GAME
NEXT
END SUB
SUB PUTCHECKER (P, RD, KING)
X = XY(P).X + 14
Y = XY(P).Y + 10
CIRCLE (X, Y), 10, 1
IF RD THEN
PAINT (X, Y), 2, 1
END IF
IF KING THEN
DRAW "C1BM" + STR$(X + 2) + "," + STR$(Y + 2) + "L8U6F4E2F2E4D6L8"
END IF
END SUB
FUNCTION SCAN (POSITION)
FOUNDR = FALSE
FOR PN = 1 TO NUMREDS
IF REDS(PN).PST = POSITION THEN
FOUNDR = TRUE
C = PN
EXIT FOR
END IF
NEXT
IF FOUNDR <> TRUE THEN
FOUNDB = FALSE
FOR PN = 1 TO NUMBLACKS
IF BLACKS(PN).PST = POSITION THEN
FOUNDB = TRUE
C = PN
EXIT FOR
END IF
NEXT
END IF
IF FOUNDR THEN
SCAN = RED
ELSEIF FOUNDB THEN
SCAN = BLACK
ELSE
SCAN = NULL
END IF
END FUNCTION
SUB SCANAROUND (PIECE, C)
SELECT CASE C
CASE RED
POSITION = REDS(PIECE).PST
CASE BLACK
POSITION = BLACKS(PIECE).PST
END SELECT
TEMPNUM = 0
IF NOT ISTOP(POSITION) THEN
IF NOT ISLEFT(POSITION) THEN
TEMPPOS(TEMPNUM) = TOPLEFT(POSITION)
TEMPNUM = INCREMENT(TEMPNUM)
END IF
IF NOT ISRIGHT(POSITION) THEN
TEMPPOS(TEMPNUM) = TOPRIGHT(POSITION)
TEMPNUM = INCREMENT(TEMPNUM)
END IF
END IF
IF NOT ISBOTTOM(POSITION) THEN
IF NOT ISLEFT(POSITION) THEN
TEMPPOS(TEMPNUM) = BOTTOMLEFT(POSITION)
TEMPNUM = INCREMENT(TEMPNUM)
END IF
IF NOT ISRIGHT(POSITION) THEN
TEMPPOS(TEMPNUM) = BOTTOMRIGHT(POSITION)
TEMPNUM = INCREMENT(TEMPNUM)
END IF
END IF
END SUB
FUNCTION SELECTPIECE (FLASH)
STATIC LASTCHOICE, FIRSTTIME
DIM TSTART AS SINGLE
IF FIRSTTIME = 0 THEN
FIRSTTIME = -1
LASTCHOICE = 22
END IF
IF FLASH <> -1 THEN
GET (XY(FLASH).X, XY(FLASH).Y)-(XY(FLASH).X + 28, XY(FLASH).Y + 20), AG()
TSTART = TIMER
SWITCH = 0
END IF
DO
X = XY(LASTCHOICE).X
Y = XY(LASTCHOICE).Y
DO
LINE (X, Y)-(X + 28, Y + 20), 0, B
IF FLASH <> -1 AND TIMER - TSTART > .3 THEN
SWITCH = (SWITCH + 1) MOD 2
IF SWITCH = 1 THEN
PUT (XY(FLASH).X + 1, XY(FLASH).Y + 1), BG(), PSET
ELSE
PUT (XY(FLASH).X, XY(FLASH).Y), AG(), PSET
END IF
TSTART = TIMER
END IF
LINE (X, Y)-(X + 28, Y + 20), 1, B
K$ = INKEY$
LOOP UNTIL K$ <> ""
SELECT CASE ASC(RIGHT$(K$, 1))
CASE 75
LASTCHOICE = LASTCHOICE - 1
IF LASTCHOICE < 0 THEN
LASTCHOICE = 31
END IF
CASE 77
LASTCHOICE = LASTCHOICE + 1
IF LASTCHOICE > 31 THEN
LASTCHOICE = 0
END IF
CASE 13, 32
SELECTPIECE = LASTCHOICE
END SELECT
LOOP UNTIL K$ = "T" OR K$ = "t" OR K$ = "q" OR K$ = "Q" OR K$ = " " OR K$ = CHR$(13)
IF FLASH <> -1 THEN
PUT (XY(FLASH).X, XY(FLASH).Y), AG(), PSET
END IF
END FUNCTION
SUB TESTCOMPUTERSMOVES
FOR A = 1 TO NUMBLACKS
ALLMOVES A, BLACK, FALSE
NEXT
END SUB
FUNCTION TOPLEFT (POSITION)
FIRST = INT(POSITION / 4) * 4
IF (FIRST AND 4) = 0 THEN
TOPLEFT = POSITION - 4
ELSE
TOPLEFT = POSITION - 5
END IF
END FUNCTION
FUNCTION TOPRIGHT (POSITION)
FIRST = INT(POSITION / 4) * 4
IF (FIRST AND 4) = 0 THEN
TOPRIGHT = POSITION - 3
ELSE
TOPRIGHT = POSITION - 4
END IF
END FUNCTION
SUB UPDATE
FOR A = 0 TO 31
ERASECHECKER A
NEXT
FOR A = 1 TO NUMREDS
PUTCHECKER REDS(A).PST, TRUE, REDS(A).KING
NEXT
FOR A = 1 TO NUMBLACKS
PUTCHECKER BLACKS(A).PST, FALSE, BLACKS(A).KING
NEXT
END SUB
|
|
