games/checkers/checkers.bas

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