You are not logged in or registered. Please login or register to use the full functionality of this board...
SIGN IN Join Our Community For FREE


CHECKERX.
06-18-2014, 04:28 AM (This post was last modified: 04-03-2015 11:40 AM by Anthony.R.Brown.)
Post: #1
 (Print Post)
CHECKERX.
This is a Checkers Game...that could be improved,like Full Screen & maybe even 3D Smile the important thing is that it does Play a Nice Strong Game!.

Anthony.


Code Snippet: [Select]
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

SCREENSHOT ADDED BY ADMINISTRATOR:

   
Find all posts by this user
Like Post



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Pivot version two
QB64 Member Project - Color Triangles
QB64 Member Project - Pivet version one
QB64 Member Project - Connect Four
QB64 Member Project - Basic Dithering
QB64 Member Project - Input
QB64 Member Project - Full Color LED Sign
QB64 Member Project - Qubic
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Touche
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Overboard
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - Kings Court
QB64 Member Project - Exit
QB64 Member Project - Isolation
QB64 Member Project - Rubix's Magic
QB64 Member Project - Bowditch curve
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Foursight
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Spiro Roses
QB64 Member Project - Dreamy Clock
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Blokus
QB64 Member Project - Kings Valley verion one
QB64 Member Project - Swirl
QB64 Member Project - Dakapo
QB64 Member Project - RGB Color Wheel
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Splatter
QB64 Member Project - Domain
QB64 Member Project - Point Blank
QB64 Member Project - Line Thickness
QB64 Member Project - Inside Moves
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - Othello
QB64 Member Project - 9 Board
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Amazon
QB64 Member Project - Color Rotating Text
QB64 Member Project - Score 4
QB64 Member Project - ARB Checkers
QB64 Member Project - Sabotage
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Algeria Weather
QB64 Member Project - Quarto
QB64 Member Project - Rotating Background