' Checkers game (unfinished)
' by Svjatoslav Agejenko 2001
' svjatoslavagejenko@gmail.com


DECLARE SUB compki (m%, h%, x1%, y1%)
DECLARE SUB compgo2 (h%)
DECLARE SUB compgo (h%)
DECLARE SUB humngo (h%)
DEFINT A-Z

DECLARE SUB thinkc ()
DECLARE SUB thinkh ()
DECLARE SUB cmd (a$)
DECLARE SUB freet ()
DECLARE SUB prn (x%, y%, c%, a$)
DECLARE SUB msg (a$, c)
DECLARE SUB getfnt ()
DECLARE SUB playg ()
DECLARE SUB geth ()
DECLARE SUB start ()
DECLARE SUB mklau ()
DECLARE SUB showr (x, y)
DECLARE SUB show ()
DIM SHARED font(0 TO 7, 0 TO 7, 0 TO 255)
DIM SHARED siz, fi, ri, rs
DIM SHARED stri$
DIM SHARED humx1, humy1, humx2, humy2
DIM SHARED sug, smax
DIM SHARED npos AS LONG
DIM SHARED cx1, cy1, cx2, cy2

siz = 6         ' Board size
fi = 0
ri = 2
smax = 3        ' thinking depth


DIM SHARED lau(-1 TO siz + 2, -1 TO siz + 2)

start
mklau
show
playg

SUB cmd (a$)

mitus = 0
DIM sona$(1 TO 10)
FOR b = 1 TO 10
sona$(b) = ""
NEXT b

d = 1
e = 1
FOR b = 1 TO LEN(a$)
c$ = RIGHT$(LEFT$(a$, b), 1)
IF c$ = " " THEN
IF e = 0 THEN d = d + 1: e = 1
GOTO 4
END IF
e = 0
sona$(d) = sona$(d) + c$
4
NEXT b
IF e = 1 THEN d = d - 1
mitus = d


SELECT CASE sona$(1)
CASE "m"
IF humx1 > 0 THEN msg "move replaced", 14

humx1 = ASC(LEFT$(sona$(2), 1)) - 64
IF humx1 > 32 THEN humx1 = humx1 - 32
humy1 = VAL(RIGHT$(sona$(2), LEN(sona$(2)) - 1))
humx2 = ASC(LEFT$(sona$(3), 1)) - 64
IF humx2 > 32 THEN humx2 = humx2 - 32
humy2 = VAL(RIGHT$(sona$(3), LEN(sona$(2)) - 1))

CASE "h"
msg "h - display help screen", 14
msg "q - to quit", 14
msg "m <from> <to> - make move", 14
msg "n - no. positions processed", 14

CASE "q"
SYSTEM

CASE "n"
b$ = "positions processed:" + STR$(npos)
msg b$, 14

END SELECT

END SUB

SUB compgo (h)
IF sug > smax THEN h = 0: GOTO 6
sug = sug + 1
npos = npos + 1
freet
IF sug = 1 THEN h1 = -2000 ELSE h1 = -1000

'cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1
b = 0
c = 0
m = 0
FOR y = 1 TO siz        ' check for eating
FOR x = 1 TO siz
IF lau(x, y) = 1 THEN
8
IF (lau(x - 1, y + 1) = 2) AND (lau(x - 2, y + 2) = 0) THEN
SWAP lau(x, y), lau(x - 2, y + 2)
lau(x - 1, y + 1) = 0
compki m1, h2, x - 2, y + 2
lau(x - 1, y + 1) = 2
SWAP lau(x, y), lau(x - 2, y + 2)
m1 = m1 + 1
IF m1 > m THEN m = m1: h1 = -1000
IF m1 = m THEN
IF h2 + 1 > h1 THEN
h1 = h2 + 1
IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y + 2
END IF
END IF
b = 1
END IF


IF (lau(x + 1, y + 1) = 2) AND (lau(x + 2, y + 2) = 0) THEN
SWAP lau(x, y), lau(x + 2, y + 2)
lau(x + 1, y + 1) = 0
compki m1, h2, x + 2, y + 2
lau(x + 1, y + 1) = 2
SWAP lau(x, y), lau(x + 2, y + 2)
m1 = m1 + 1
IF m1 > m THEN m = m1: h1 = -1000
IF m1 = m THEN
IF h2 + 1 > h1 THEN
h1 = h2 + 1
IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y + 2
END IF
END IF
b = 1
END IF


IF (lau(x - 1, y - 1) = 2) AND (lau(x - 2, y - 2) = 0) THEN
SWAP lau(x, y), lau(x - 2, y - 2)
lau(x - 1, y - 1) = 0
compki m1, h2, x - 2, y - 2
lau(x - 1, y - 1) = 2
SWAP lau(x, y), lau(x - 2, y - 2)
m1 = m1 + 1
IF m1 > m THEN m = m1: h1 = -1000
IF m1 = m THEN
IF h2 + 1 > h1 THEN
h1 = h2 + 1
IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y - 2
END IF
END IF
b = 1
END IF


IF (lau(x + 1, y - 1) = 2) AND (lau(x + 2, y - 2) = 0) THEN
SWAP lau(x, y), lau(x + 2, y - 2)
lau(x + 1, y - 1) = 0
compki m1, h2, x + 2, y - 2
lau(x + 1, y - 1) = 2
SWAP lau(x, y), lau(x + 2, y - 2)
m1 = m1 + 1
IF m1 > m THEN m = m1: h1 = -1000
IF m1 = m THEN
IF h2 + 1 > h1 THEN
h1 = h2 + 1
IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y - 2
END IF
END IF
b = 1
END IF





IF c = 1 THEN GOTO 9
END IF
NEXT x
NEXT y

9
IF (b = 1) AND (npos = 1) THEN
cx3 = (cx1 + cx2) / 2
cy3 = (cy1 + cy2) / 2
lau(cx3, cy3) = 0
showr cx3, cy3

SWAP lau(cx1, cy1), lau(cx2, cy2)
showr cx1, cy1
showr cx2, cy2
msg "NJAM!", 10
x = cx2
y = cy2
c = 1
b = 0
GOTO 8
END IF
IF c = 1 THEN
cx1 = 1: cy1 = 1: cx2 = 1: cy2 = 1
GOTO 10
END IF

IF sug = 1 THEN
msg "l��a ei saa", 4
msg STR$(h1), 4
END IF

FOR y = 1 TO siz    ' unuseful move
FOR x = 1 TO siz
IF lau(x, y) = 1 THEN
IF lau(x - 1, y + 1) = 0 THEN
SWAP lau(x, y), lau(x - 1, y + 1)
humngo h2
SWAP lau(x, y), lau(x - 1, y + 1)
IF h2 > h1 THEN
h1 = h2
IF sug = 1 THEN cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1
END IF
END IF

IF lau(x + 1, y + 1) = 0 THEN
SWAP lau(x, y), lau(x + 1, y + 1)
humngo h2
SWAP lau(x, y), lau(x + 1, y + 1)
IF h2 > h1 THEN
h1 = h2
IF sug = 1 THEN cx1 = x: cy1 = y: cx2 = x + 1: cy2 = y + 1
END IF
END IF

END IF
NEXT x
NEXT y
h = h1
10
sug = sug - 1
6
END SUB

SUB compki (m, h, x1, y1)
h1 = 0

FOR y = 1 TO siz
FOR x = 1 TO siz
NEXT x
NEXT y
h = h1

END SUB

SUB freet
a$ = INKEY$
IF a$ = "" THEN
ELSE
IF a$ = CHR$(8) THEN
IF LEN(stri$) > 0 THEN
stri$ = LEFT$(stri$, LEN(stri$) - 1): GOTO 3
END IF
END IF
IF a$ = CHR$(13) THEN
IF LEN(stri$) > 0 THEN
msg stri$, 7
cmd stri$
stri$ = ""
END IF
GOTO 3
END IF
stri$ = stri$ + a$
3
LINE (400, 468)-(639, 479), 1, BF
prn 405, 469, 14, stri$
END IF
END SUB

SUB getfnt
SCREEN 13
FOR a = 0 TO 255
IF (a > 5) AND (a < 17) THEN GOTO 2
LOCATE 1, 1
PRINT CHR$(a)
2
FOR y = 0 TO 7
FOR x = 0 TO 7
font(x, y, a) = POINT(x, y)
NEXT x
NEXT y
NEXT a

END SUB

SUB humngo (h)
npos = npos + 1
h1 = 1000

FOR y = siz TO 1 STEP -1
FOR x = siz TO 1 STEP -1
IF lau(x, y) = 2 THEN
IF lau(x - 1, y - 1) = 0 THEN
SWAP lau(x, y), lau(x - 1, y - 1)
compgo h2
SWAP lau(x, y), lau(x - 1, y - 1)
IF h2 < h1 THEN h1 = h2
END IF

IF lau(x + 1, y - 1) = 0 THEN
SWAP lau(x, y), lau(x + 1, y - 1)
compgo h2
SWAP lau(x, y), lau(x + 1, y - 1)
IF h2 < h1 THEN h1 = h2
END IF


IF (lau(x - 1, y - 1) = 1) AND (lau(x - 2, y - 2) = 0) THEN
SWAP lau(x, y), lau(x - 2, y - 2)
lau(x - 1, y - 1) = 0
humngo h2
lau(x - 1, y - 1) = 1
SWAP lau(x, y), lau(x - 2, y - 2)
IF h2 - 1 < h1 THEN h1 = h2 - 1
END IF

IF (lau(x + 1, y - 1) = 1) AND (lau(x + 2, y - 2) = 0) THEN
SWAP lau(x, y), lau(x + 2, y - 2)
lau(x + 1, y - 1) = 0
humngo h2
lau(x + 1, y - 1) = 1
SWAP lau(x, y), lau(x + 2, y - 2)
IF h2 - 1 < h1 THEN h1 = h2 - 1
END IF




END IF
NEXT x
NEXT y
h = h1
END SUB

SUB mklau
FOR y = -1 TO siz + 2
FOR x = -1 TO siz + 2
lau(x, y) = -1
NEXT x
NEXT y

FOR y = 1 TO siz
FOR x = 1 TO siz
lau(x, y) = 0
NEXT x
NEXT y

FOR y = 1 TO ri
FOR x = 1 TO siz
IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN
lau(x, y) = 1
END IF
NEXT x
NEXT y

FOR y = siz - ri + 1 TO siz
FOR x = 1 TO siz
IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN
lau(x, y) = 2
END IF
NEXT x
NEXT y

END SUB

SUB msg (a$, c)
DIM buf(1 TO 10000)
FOR x = 400 TO 630 STEP 40
GET (x, 8)-(x + 39, 467), buf(1)
PUT (x, 0), buf(1), PSET
NEXT x
LINE (400, 460)-(639, 467), 0, BF
prn 405, 460, c, a$
END SUB

SUB playg
'GOTO 7
1
thinkc
show
7
thinkh
show
GOTO 1


END SUB

SUB prn (x, y, c, a$)
x1 = x
y1 = y
FOR a = 1 TO LEN(a$)
b = ASC(RIGHT$(LEFT$(a$, a), 1))
FOR y2 = 0 TO 7
FOR x2 = 0 TO 7
IF font(x2, y2, b) > 0 THEN PSET (x2 + x1, y2 + y1), c
NEXT x2
NEXT y2
x1 = x1 + 8
NEXT a
END SUB

SUB show
FOR y = 1 TO siz
FOR x = 1 TO siz
showr x, y
NEXT x
NEXT y

sp = rs / 2
FOR x = 1 TO siz
prn ((x - 1) * rs + 12 + sp), 2, 10, CHR$(64 + x)
prn ((x - 1) * rs + 12 + sp), siz * rs + 11, 10, CHR$(64 + x)
NEXT x

FOR y = 1 TO siz
a$ = STR$(y)
a$ = RIGHT$(a$, LEN(a$) - 1)
prn 15 - (LEN(a$) * 8), (y - 1) * rs + sp + 7, 10, a$
prn (siz * rs + 16), (y - 1) * rs + sp + 7, 10, a$
NEXT y


END SUB

SUB showr (x, y)
IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN c = 8 ELSE c = 7
x1 = (x - 1) * rs + 15
y1 = (y - 1) * rs + 10
LINE (x1, y1)-(x1 + rs - 1, y1 + rs - 1), c, BF
IF lau(x, y) > 0 THEN
sp = rs / 2
IF lau(x, y) = 1 THEN c1 = 15 ELSE c1 = 14
CIRCLE (x1 + sp, y1 + sp), sp - 1, c1
PAINT (x1 + sp, y1 + sp), c1
END IF
END SUB

SUB start
getfnt
SCREEN 12
LINE (399, 0)-(399, 479), 13
msg "type 'h' for help", 14

rs = INT(370 / siz)


END SUB

SUB thinkc
msg "computer turn", 14
sug = 0
npos = 0
cx1 = -1

compgo h
cmd "n"
IF cx1 = -1 THEN msg "you won!", 10: msg "--------", 10: SYSTEM

IF h <= -2 THEN msg "oh no...", 10
IF h = -1 THEN msg "oops!", 10
IF h = 1 THEN msg "yess! I will eat soon!", 10
IF h >= 2 THEN msg "HA HA HA YOU ARE IN TROUBLE!", 10


IF ABS(cx1 - cx2) = 2 THEN
cx3 = (cx1 + cx2) / 2
cy3 = (cy1 + cy2) / 2
lau(cx3, cy3) = 0
showr cx3, cy3
END IF

SWAP lau(cx1, cy1), lau(cx2, cy2)
showr cx1, cy1
showr cx2, cy2

END SUB

SUB thinkh
msg "your turn", 14
5
freet
IF humx1 = 0 THEN GOTO 5
SWAP lau(humx2, humy2), lau(humx1, humy1)
showr humx1, humy1
showr humx2, humy2
IF ABS(humx1 - humx2) = 2 THEN
cx3 = (humx1 + humx2) / 2
cy3 = (humy1 + humy2) / 2
lau(cx3, cy3) = 0
showr cx3, cy3
END IF

humx1 = 0
END SUB