games/checkers/checkers.bas

   1 ' Checkers game (unfinished)\r
   2 ' by Svjatoslav Agejenko 2001\r
   3 \r
   4 \r
   5 DECLARE SUB compki (m%, h%, x1%, y1%)\r
   6 DECLARE SUB compgo2 (h%)\r
   7 DECLARE SUB compgo (h%)\r
   8 DECLARE SUB humngo (h%)\r
   9 DEFINT A-Z\r
  10 \r
  11 DECLARE SUB thinkc ()\r
  12 DECLARE SUB thinkh ()\r
  13 DECLARE SUB cmd (a$)\r
  14 DECLARE SUB freet ()\r
  15 DECLARE SUB prn (x%, y%, c%, a$)\r
  16 DECLARE SUB msg (a$, c)\r
  17 DECLARE SUB getfnt ()\r
  18 DECLARE SUB playg ()\r
  19 DECLARE SUB geth ()\r
  20 DECLARE SUB start ()\r
  21 DECLARE SUB mklau ()\r
  22 DECLARE SUB showr (x, y)\r
  23 DECLARE SUB show ()\r
  24 DIM SHARED font(0 TO 7, 0 TO 7, 0 TO 255)\r
  25 DIM SHARED siz, fi, ri, rs\r
  26 DIM SHARED stri$\r
  27 DIM SHARED humx1, humy1, humx2, humy2\r
  28 DIM SHARED sug, smax\r
  29 DIM SHARED npos AS LONG\r
  30 DIM SHARED cx1, cy1, cx2, cy2\r
  31 \r
  32 siz = 6         ' Board size\r
  33 fi = 0\r
  34 ri = 2\r
  35 smax = 3        ' thinking depth\r
  36 \r
  37 \r
  38 DIM SHARED lau(-1 TO siz + 2, -1 TO siz + 2)\r
  39 \r
  40 start\r
  41 mklau\r
  42 show\r
  43 playg\r
  44 \r
  45 SUB cmd (a$)\r
  46 \r
  47 mitus = 0\r
  48 DIM sona$(1 TO 10)\r
  49 FOR b = 1 TO 10\r
  50 sona$(b) = ""\r
  51 NEXT b\r
  52 \r
  53 d = 1\r
  54 e = 1\r
  55 FOR b = 1 TO LEN(a$)\r
  56 c$ = RIGHT$(LEFT$(a$, b), 1)\r
  57 IF c$ = " " THEN\r
  58 IF e = 0 THEN d = d + 1: e = 1\r
  59 GOTO 4\r
  60 END IF\r
  61 e = 0\r
  62 sona$(d) = sona$(d) + c$\r
  63 4\r
  64 NEXT b\r
  65 IF e = 1 THEN d = d - 1\r
  66 mitus = d\r
  67 \r
  68 \r
  69 SELECT CASE sona$(1)\r
  70 CASE "m"\r
  71 IF humx1 > 0 THEN msg "move replaced", 14\r
  72 \r
  73 humx1 = ASC(LEFT$(sona$(2), 1)) - 64\r
  74 IF humx1 > 32 THEN humx1 = humx1 - 32\r
  75 humy1 = VAL(RIGHT$(sona$(2), LEN(sona$(2)) - 1))\r
  76 humx2 = ASC(LEFT$(sona$(3), 1)) - 64\r
  77 IF humx2 > 32 THEN humx2 = humx2 - 32\r
  78 humy2 = VAL(RIGHT$(sona$(3), LEN(sona$(2)) - 1))\r
  79 \r
  80 CASE "h"\r
  81 msg "h - display help screen", 14\r
  82 msg "q - to quit", 14\r
  83 msg "m <from> <to> - make move", 14\r
  84 msg "n - no. positions processed", 14\r
  85 \r
  86 CASE "q"\r
  87 SYSTEM\r
  88 \r
  89 CASE "n"\r
  90 b$ = "positions processed:" + STR$(npos)\r
  91 msg b$, 14\r
  92 \r
  93 END SELECT\r
  94 \r
  95 END SUB\r
  96 \r
  97 SUB compgo (h)\r
  98 IF sug > smax THEN h = 0: GOTO 6\r
  99 sug = sug + 1\r
 100 npos = npos + 1\r
 101 freet\r
 102 IF sug = 1 THEN h1 = -2000 ELSE h1 = -1000\r
 103 \r
 104 'cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1\r
 105 b = 0\r
 106 c = 0\r
 107 m = 0\r
 108 FOR y = 1 TO siz        ' check for eating\r
 109 FOR x = 1 TO siz\r
 110 IF lau(x, y) = 1 THEN\r
 111 8\r
 112 IF (lau(x - 1, y + 1) = 2) AND (lau(x - 2, y + 2) = 0) THEN\r
 113 SWAP lau(x, y), lau(x - 2, y + 2)\r
 114 lau(x - 1, y + 1) = 0\r
 115 compki m1, h2, x - 2, y + 2\r
 116 lau(x - 1, y + 1) = 2\r
 117 SWAP lau(x, y), lau(x - 2, y + 2)\r
 118 m1 = m1 + 1\r
 119 IF m1 > m THEN m = m1: h1 = -1000\r
 120 IF m1 = m THEN\r
 121 IF h2 + 1 > h1 THEN\r
 122 h1 = h2 + 1\r
 123 IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y + 2\r
 124 END IF\r
 125 END IF\r
 126 b = 1\r
 127 END IF\r
 128 \r
 129 \r
 130 IF (lau(x + 1, y + 1) = 2) AND (lau(x + 2, y + 2) = 0) THEN\r
 131 SWAP lau(x, y), lau(x + 2, y + 2)\r
 132 lau(x + 1, y + 1) = 0\r
 133 compki m1, h2, x + 2, y + 2\r
 134 lau(x + 1, y + 1) = 2\r
 135 SWAP lau(x, y), lau(x + 2, y + 2)\r
 136 m1 = m1 + 1\r
 137 IF m1 > m THEN m = m1: h1 = -1000\r
 138 IF m1 = m THEN\r
 139 IF h2 + 1 > h1 THEN\r
 140 h1 = h2 + 1\r
 141 IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y + 2\r
 142 END IF\r
 143 END IF\r
 144 b = 1\r
 145 END IF\r
 146 \r
 147 \r
 148 IF (lau(x - 1, y - 1) = 2) AND (lau(x - 2, y - 2) = 0) THEN\r
 149 SWAP lau(x, y), lau(x - 2, y - 2)\r
 150 lau(x - 1, y - 1) = 0\r
 151 compki m1, h2, x - 2, y - 2\r
 152 lau(x - 1, y - 1) = 2\r
 153 SWAP lau(x, y), lau(x - 2, y - 2)\r
 154 m1 = m1 + 1\r
 155 IF m1 > m THEN m = m1: h1 = -1000\r
 156 IF m1 = m THEN\r
 157 IF h2 + 1 > h1 THEN\r
 158 h1 = h2 + 1\r
 159 IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y - 2\r
 160 END IF\r
 161 END IF\r
 162 b = 1\r
 163 END IF\r
 164 \r
 165 \r
 166 IF (lau(x + 1, y - 1) = 2) AND (lau(x + 2, y - 2) = 0) THEN\r
 167 SWAP lau(x, y), lau(x + 2, y - 2)\r
 168 lau(x + 1, y - 1) = 0\r
 169 compki m1, h2, x + 2, y - 2\r
 170 lau(x + 1, y - 1) = 2\r
 171 SWAP lau(x, y), lau(x + 2, y - 2)\r
 172 m1 = m1 + 1\r
 173 IF m1 > m THEN m = m1: h1 = -1000\r
 174 IF m1 = m THEN\r
 175 IF h2 + 1 > h1 THEN\r
 176 h1 = h2 + 1\r
 177 IF npos = 1 THEN cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y - 2\r
 178 END IF\r
 179 END IF\r
 180 b = 1\r
 181 END IF\r
 182 \r
 183 \r
 184 \r
 185 \r
 186 \r
 187 IF c = 1 THEN GOTO 9\r
 188 END IF\r
 189 NEXT x\r
 190 NEXT y\r
 191 \r
 192 9\r
 193 IF (b = 1) AND (npos = 1) THEN\r
 194 cx3 = (cx1 + cx2) / 2\r
 195 cy3 = (cy1 + cy2) / 2\r
 196 lau(cx3, cy3) = 0\r
 197 showr cx3, cy3\r
 198 \r
 199 SWAP lau(cx1, cy1), lau(cx2, cy2)\r
 200 showr cx1, cy1\r
 201 showr cx2, cy2\r
 202 msg "NJAM!", 10\r
 203 x = cx2\r
 204 y = cy2\r
 205 c = 1\r
 206 b = 0\r
 207 GOTO 8\r
 208 END IF\r
 209 IF c = 1 THEN\r
 210 cx1 = 1: cy1 = 1: cx2 = 1: cy2 = 1\r
 211 GOTO 10\r
 212 END IF\r
 213 \r
 214 IF sug = 1 THEN\r
 215 msg "l��a ei saa", 4\r
 216 msg STR$(h1), 4\r
 217 END IF\r
 218 \r
 219 FOR y = 1 TO siz    ' unuseful move\r
 220 FOR x = 1 TO siz\r
 221 IF lau(x, y) = 1 THEN\r
 222 IF lau(x - 1, y + 1) = 0 THEN\r
 223 SWAP lau(x, y), lau(x - 1, y + 1)\r
 224 humngo h2\r
 225 SWAP lau(x, y), lau(x - 1, y + 1)\r
 226 IF h2 > h1 THEN\r
 227 h1 = h2\r
 228 IF sug = 1 THEN cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1\r
 229 END IF\r
 230 END IF\r
 231 \r
 232 IF lau(x + 1, y + 1) = 0 THEN\r
 233 SWAP lau(x, y), lau(x + 1, y + 1)\r
 234 humngo h2\r
 235 SWAP lau(x, y), lau(x + 1, y + 1)\r
 236 IF h2 > h1 THEN\r
 237 h1 = h2\r
 238 IF sug = 1 THEN cx1 = x: cy1 = y: cx2 = x + 1: cy2 = y + 1\r
 239 END IF\r
 240 END IF\r
 241 \r
 242 END IF\r
 243 NEXT x\r
 244 NEXT y\r
 245 h = h1\r
 246 10\r
 247 sug = sug - 1\r
 248 6\r
 249 END SUB\r
 250 \r
 251 SUB compki (m, h, x1, y1)\r
 252 h1 = 0\r
 253 \r
 254 FOR y = 1 TO siz\r
 255 FOR x = 1 TO siz\r
 256 NEXT x\r
 257 NEXT y\r
 258 h = h1\r
 259 \r
 260 END SUB\r
 261 \r
 262 SUB freet\r
 263 a$ = INKEY$\r
 264 IF a$ = "" THEN\r
 265 ELSE\r
 266 IF a$ = CHR$(8) THEN\r
 267 IF LEN(stri$) > 0 THEN\r
 268 stri$ = LEFT$(stri$, LEN(stri$) - 1): GOTO 3\r
 269 END IF\r
 270 END IF\r
 271 IF a$ = CHR$(13) THEN\r
 272 IF LEN(stri$) > 0 THEN\r
 273 msg stri$, 7\r
 274 cmd stri$\r
 275 stri$ = ""\r
 276 END IF\r
 277 GOTO 3\r
 278 END IF\r
 279 stri$ = stri$ + a$\r
 280 3\r
 281 LINE (400, 468)-(639, 479), 1, BF\r
 282 prn 405, 469, 14, stri$\r
 283 END IF\r
 284 END SUB\r
 285 \r
 286 SUB getfnt\r
 287 SCREEN 13\r
 288 FOR a = 0 TO 255\r
 289 IF (a > 5) AND (a < 17) THEN GOTO 2\r
 290 LOCATE 1, 1\r
 291 PRINT CHR$(a)\r
 292 2\r
 293 FOR y = 0 TO 7\r
 294 FOR x = 0 TO 7\r
 295 font(x, y, a) = POINT(x, y)\r
 296 NEXT x\r
 297 NEXT y\r
 298 NEXT a\r
 299 \r
 300 END SUB\r
 301 \r
 302 SUB humngo (h)\r
 303 npos = npos + 1\r
 304 h1 = 1000\r
 305 \r
 306 FOR y = siz TO 1 STEP -1\r
 307 FOR x = siz TO 1 STEP -1\r
 308 IF lau(x, y) = 2 THEN\r
 309 IF lau(x - 1, y - 1) = 0 THEN\r
 310 SWAP lau(x, y), lau(x - 1, y - 1)\r
 311 compgo h2\r
 312 SWAP lau(x, y), lau(x - 1, y - 1)\r
 313 IF h2 < h1 THEN h1 = h2\r
 314 END IF\r
 315 \r
 316 IF lau(x + 1, y - 1) = 0 THEN\r
 317 SWAP lau(x, y), lau(x + 1, y - 1)\r
 318 compgo h2\r
 319 SWAP lau(x, y), lau(x + 1, y - 1)\r
 320 IF h2 < h1 THEN h1 = h2\r
 321 END IF\r
 322 \r
 323 \r
 324 IF (lau(x - 1, y - 1) = 1) AND (lau(x - 2, y - 2) = 0) THEN\r
 325 SWAP lau(x, y), lau(x - 2, y - 2)\r
 326 lau(x - 1, y - 1) = 0\r
 327 humngo h2\r
 328 lau(x - 1, y - 1) = 1\r
 329 SWAP lau(x, y), lau(x - 2, y - 2)\r
 330 IF h2 - 1 < h1 THEN h1 = h2 - 1\r
 331 END IF\r
 332 \r
 333 IF (lau(x + 1, y - 1) = 1) AND (lau(x + 2, y - 2) = 0) THEN\r
 334 SWAP lau(x, y), lau(x + 2, y - 2)\r
 335 lau(x + 1, y - 1) = 0\r
 336 humngo h2\r
 337 lau(x + 1, y - 1) = 1\r
 338 SWAP lau(x, y), lau(x + 2, y - 2)\r
 339 IF h2 - 1 < h1 THEN h1 = h2 - 1\r
 340 END IF\r
 341 \r
 342 \r
 343 \r
 344 \r
 345 END IF\r
 346 NEXT x\r
 347 NEXT y\r
 348 h = h1\r
 349 END SUB\r
 350 \r
 351 SUB mklau\r
 352 FOR y = -1 TO siz + 2\r
 353 FOR x = -1 TO siz + 2\r
 354 lau(x, y) = -1\r
 355 NEXT x\r
 356 NEXT y\r
 357 \r
 358 FOR y = 1 TO siz\r
 359 FOR x = 1 TO siz\r
 360 lau(x, y) = 0\r
 361 NEXT x\r
 362 NEXT y\r
 363 \r
 364 FOR y = 1 TO ri\r
 365 FOR x = 1 TO siz\r
 366 IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN\r
 367 lau(x, y) = 1\r
 368 END IF\r
 369 NEXT x\r
 370 NEXT y\r
 371 \r
 372 FOR y = siz - ri + 1 TO siz\r
 373 FOR x = 1 TO siz\r
 374 IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN\r
 375 lau(x, y) = 2\r
 376 END IF\r
 377 NEXT x\r
 378 NEXT y\r
 379 \r
 380 END SUB\r
 381 \r
 382 SUB msg (a$, c)\r
 383 DIM buf(1 TO 10000)\r
 384 FOR x = 400 TO 630 STEP 40\r
 385 GET (x, 8)-(x + 39, 467), buf(1)\r
 386 PUT (x, 0), buf(1), PSET\r
 387 NEXT x\r
 388 LINE (400, 460)-(639, 467), 0, BF\r
 389 prn 405, 460, c, a$\r
 390 END SUB\r
 391 \r
 392 SUB playg\r
 393 'GOTO 7\r
 394 1\r
 395 thinkc\r
 396 show\r
 397 7\r
 398 thinkh\r
 399 show\r
 400 GOTO 1\r
 401 \r
 402 \r
 403 END SUB\r
 404 \r
 405 SUB prn (x, y, c, a$)\r
 406 x1 = x\r
 407 y1 = y\r
 408 FOR a = 1 TO LEN(a$)\r
 409 b = ASC(RIGHT$(LEFT$(a$, a), 1))\r
 410 FOR y2 = 0 TO 7\r
 411 FOR x2 = 0 TO 7\r
 412 IF font(x2, y2, b) > 0 THEN PSET (x2 + x1, y2 + y1), c\r
 413 NEXT x2\r
 414 NEXT y2\r
 415 x1 = x1 + 8\r
 416 NEXT a\r
 417 END SUB\r
 418 \r
 419 SUB show\r
 420 FOR y = 1 TO siz\r
 421 FOR x = 1 TO siz\r
 422 showr x, y\r
 423 NEXT x\r
 424 NEXT y\r
 425 \r
 426 sp = rs / 2\r
 427 FOR x = 1 TO siz\r
 428 prn ((x - 1) * rs + 12 + sp), 2, 10, CHR$(64 + x)\r
 429 prn ((x - 1) * rs + 12 + sp), siz * rs + 11, 10, CHR$(64 + x)\r
 430 NEXT x\r
 431 \r
 432 FOR y = 1 TO siz\r
 433 a$ = STR$(y)\r
 434 a$ = RIGHT$(a$, LEN(a$) - 1)\r
 435 prn 15 - (LEN(a$) * 8), (y - 1) * rs + sp + 7, 10, a$\r
 436 prn (siz * rs + 16), (y - 1) * rs + sp + 7, 10, a$\r
 437 NEXT y\r
 438 \r
 439 \r
 440 END SUB\r
 441 \r
 442 SUB showr (x, y)\r
 443 IF (x + y + fi) / 2 = INT((x + y + fi) / 2) THEN c = 8 ELSE c = 7\r
 444 x1 = (x - 1) * rs + 15\r
 445 y1 = (y - 1) * rs + 10\r
 446 LINE (x1, y1)-(x1 + rs - 1, y1 + rs - 1), c, BF\r
 447 IF lau(x, y) > 0 THEN\r
 448 sp = rs / 2\r
 449 IF lau(x, y) = 1 THEN c1 = 15 ELSE c1 = 14\r
 450 CIRCLE (x1 + sp, y1 + sp), sp - 1, c1\r
 451 PAINT (x1 + sp, y1 + sp), c1\r
 452 END IF\r
 453 END SUB\r
 454 \r
 455 SUB start\r
 456 getfnt\r
 457 SCREEN 12\r
 458 LINE (399, 0)-(399, 479), 13\r
 459 msg "type 'h' for help", 14\r
 460 \r
 461 rs = INT(370 / siz)\r
 462 \r
 463 \r
 464 END SUB\r
 465 \r
 466 SUB thinkc\r
 467 msg "computer turn", 14\r
 468 sug = 0\r
 469 npos = 0\r
 470 cx1 = -1\r
 471 \r
 472 compgo h\r
 473 cmd "n"\r
 474 IF cx1 = -1 THEN msg "you won!", 10: msg "--------", 10: SYSTEM\r
 475 \r
 476 IF h <= -2 THEN msg "oh no...", 10\r
 477 IF h = -1 THEN msg "oops!", 10\r
 478 IF h = 1 THEN msg "yess! I will eat soon!", 10\r
 479 IF h >= 2 THEN msg "HA HA HA YOU ARE IN TROUBLE!", 10\r
 480 \r
 481 \r
 482 IF ABS(cx1 - cx2) = 2 THEN\r
 483 cx3 = (cx1 + cx2) / 2\r
 484 cy3 = (cy1 + cy2) / 2\r
 485 lau(cx3, cy3) = 0\r
 486 showr cx3, cy3\r
 487 END IF\r
 488 \r
 489 SWAP lau(cx1, cy1), lau(cx2, cy2)\r
 490 showr cx1, cy1\r
 491 showr cx2, cy2\r
 492 \r
 493 END SUB\r
 494 \r
 495 SUB thinkh\r
 496 msg "your turn", 14\r
 497 5\r
 498 freet\r
 499 IF humx1 = 0 THEN GOTO 5\r
 500 SWAP lau(humx2, humy2), lau(humx1, humy1)\r
 501 showr humx1, humy1\r
 502 showr humx2, humy2\r
 503 IF ABS(humx1 - humx2) = 2 THEN\r
 504 cx3 = (humx1 + humx2) / 2\r
 505 cy3 = (humy1 + humy2) / 2\r
 506 lau(cx3, cy3) = 0\r
 507 showr cx3, cy3\r
 508 END IF\r
 509 \r
 510 humx1 = 0\r
 511 END SUB\r