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