-' Checkers game (unfinished)\r
-' by Svjatoslav Agejenko 2001\r
-\r
-\r
-DECLARE SUB compki (m%, h%, x1%, y1%)\r
-DECLARE SUB compgo2 (h%)\r
-DECLARE SUB compgo (h%)\r
-DECLARE SUB humngo (h%)\r
-DefInt A-Z\r
-\r
-DECLARE SUB thinkc ()\r
-DECLARE SUB thinkh ()\r
-DECLARE SUB cmd (a$)\r
-DECLARE SUB freet ()\r
-DECLARE SUB prn (x%, y%, c%, a$)\r
-DECLARE SUB msg (a$, c)\r
-DECLARE SUB getfnt ()\r
-DECLARE SUB playg ()\r
-DECLARE SUB geth ()\r
-DECLARE SUB start ()\r
-DECLARE SUB mklau ()\r
-DECLARE SUB showr (x, y)\r
-DECLARE SUB show ()\r
-Dim Shared font(0 To 7, 0 To 7, 0 To 255)\r
-Dim Shared siz, fi, ri, rs\r
-Dim Shared stri$\r
-Dim Shared humx1, humy1, humx2, humy2\r
-Dim Shared sug, smax\r
-Dim Shared npos As Long\r
-Dim Shared cx1, cy1, cx2, cy2\r
-\r
-siz = 6 ' Board size\r
-fi = 0\r
-ri = 2\r
-smax = 3 ' thinking depth\r
-\r
-\r
-Dim Shared lau(-1 To siz + 2, -1 To siz + 2)\r
-\r
-start\r
-mklau\r
-show\r
-playg\r
-\r
-Sub cmd (a$)\r
-\r
- mitus = 0\r
- Dim sona$(1 To 10)\r
- For b = 1 To 10\r
- sona$(b) = ""\r
- Next b\r
-\r
- d = 1\r
- e = 1\r
- For b = 1 To Len(a$)\r
- c$ = Right$(Left$(a$, b), 1)\r
- If c$ = " " Then\r
- If e = 0 Then d = d + 1: e = 1\r
- GoTo 4\r
- End If\r
- e = 0\r
- sona$(d) = sona$(d) + c$\r
- 4\r
- Next b\r
- If e = 1 Then d = d - 1\r
- mitus = d\r
-\r
-\r
- Select Case sona$(1)\r
- Case "m"\r
- If humx1 > 0 Then msg "move replaced", 14\r
-\r
- humx1 = Asc(Left$(sona$(2), 1)) - 64\r
- If humx1 > 32 Then humx1 = humx1 - 32\r
- humy1 = Val(Right$(sona$(2), Len(sona$(2)) - 1))\r
- humx2 = Asc(Left$(sona$(3), 1)) - 64\r
- If humx2 > 32 Then humx2 = humx2 - 32\r
- humy2 = Val(Right$(sona$(3), Len(sona$(2)) - 1))\r
-\r
- Case "h"\r
- msg "h - display help screen", 14\r
- msg "q - to quit", 14\r
- msg "m <from> <to> - make move", 14\r
- msg "n - no. positions processed", 14\r
-\r
- Case "q"\r
- System\r
-\r
- Case "n"\r
- b$ = "positions processed:" + Str$(npos)\r
- msg b$, 14\r
-\r
- End Select\r
-\r
-End Sub\r
-\r
-Sub compgo (h)\r
- If sug > smax Then h = 0: GoTo 6\r
- sug = sug + 1\r
- npos = npos + 1\r
- freet\r
- If sug = 1 Then h1 = -2000 Else h1 = -1000\r
-\r
- 'cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1\r
- b = 0\r
- c = 0\r
- m = 0\r
- For y = 1 To siz ' check for eating\r
- For x = 1 To siz\r
- If lau(x, y) = 1 Then\r
- 8\r
- If (lau(x - 1, y + 1) = 2) And (lau(x - 2, y + 2) = 0) Then\r
- Swap lau(x, y), lau(x - 2, y + 2)\r
- lau(x - 1, y + 1) = 0\r
- compki m1, h2, x - 2, y + 2\r
- lau(x - 1, y + 1) = 2\r
- Swap lau(x, y), lau(x - 2, y + 2)\r
- m1 = m1 + 1\r
- If m1 > m Then m = m1: h1 = -1000\r
- If m1 = m Then\r
- If h2 + 1 > h1 Then\r
- h1 = h2 + 1\r
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y + 2\r
- End If\r
- End If\r
- b = 1\r
- End If\r
-\r
-\r
- If (lau(x + 1, y + 1) = 2) And (lau(x + 2, y + 2) = 0) Then\r
- Swap lau(x, y), lau(x + 2, y + 2)\r
- lau(x + 1, y + 1) = 0\r
- compki m1, h2, x + 2, y + 2\r
- lau(x + 1, y + 1) = 2\r
- Swap lau(x, y), lau(x + 2, y + 2)\r
- m1 = m1 + 1\r
- If m1 > m Then m = m1: h1 = -1000\r
- If m1 = m Then\r
- If h2 + 1 > h1 Then\r
- h1 = h2 + 1\r
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y + 2\r
- End If\r
- End If\r
- b = 1\r
- End If\r
-\r
-\r
- If (lau(x - 1, y - 1) = 2) And (lau(x - 2, y - 2) = 0) Then\r
- Swap lau(x, y), lau(x - 2, y - 2)\r
- lau(x - 1, y - 1) = 0\r
- compki m1, h2, x - 2, y - 2\r
- lau(x - 1, y - 1) = 2\r
- Swap lau(x, y), lau(x - 2, y - 2)\r
- m1 = m1 + 1\r
- If m1 > m Then m = m1: h1 = -1000\r
- If m1 = m Then\r
- If h2 + 1 > h1 Then\r
- h1 = h2 + 1\r
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x - 2: cy2 = y - 2\r
- End If\r
- End If\r
- b = 1\r
- End If\r
-\r
-\r
- If (lau(x + 1, y - 1) = 2) And (lau(x + 2, y - 2) = 0) Then\r
- Swap lau(x, y), lau(x + 2, y - 2)\r
- lau(x + 1, y - 1) = 0\r
- compki m1, h2, x + 2, y - 2\r
- lau(x + 1, y - 1) = 2\r
- Swap lau(x, y), lau(x + 2, y - 2)\r
- m1 = m1 + 1\r
- If m1 > m Then m = m1: h1 = -1000\r
- If m1 = m Then\r
- If h2 + 1 > h1 Then\r
- h1 = h2 + 1\r
- If npos = 1 Then cx1 = x: cy1 = y: cx2 = x + 2: cy2 = y - 2\r
- End If\r
- End If\r
- b = 1\r
- End If\r
-\r
-\r
-\r
-\r
-\r
- If c = 1 Then GoTo 9\r
- End If\r
- Next x\r
- Next y\r
-\r
- 9\r
- If (b = 1) And (npos = 1) Then\r
- cx3 = (cx1 + cx2) / 2\r
- cy3 = (cy1 + cy2) / 2\r
- lau(cx3, cy3) = 0\r
- showr cx3, cy3\r
-\r
- Swap lau(cx1, cy1), lau(cx2, cy2)\r
- showr cx1, cy1\r
- showr cx2, cy2\r
- msg "NJAM!", 10\r
- x = cx2\r
- y = cy2\r
- c = 1\r
- b = 0\r
- GoTo 8\r
- End If\r
- If c = 1 Then\r
- cx1 = 1: cy1 = 1: cx2 = 1: cy2 = 1\r
- GoTo 10\r
- End If\r
-\r
- If sug = 1 Then\r
- msg "l��a ei saa", 4\r
- msg Str$(h1), 4\r
- End If\r
-\r
- For y = 1 To siz ' unuseful move\r
- For x = 1 To siz\r
- If lau(x, y) = 1 Then\r
- If lau(x - 1, y + 1) = 0 Then\r
- Swap lau(x, y), lau(x - 1, y + 1)\r
- humngo h2\r
- Swap lau(x, y), lau(x - 1, y + 1)\r
- If h2 > h1 Then\r
- h1 = h2\r
- If sug = 1 Then cx1 = x: cy1 = y: cx2 = x - 1: cy2 = y + 1\r
- End If\r
- End If\r
-\r
- If lau(x + 1, y + 1) = 0 Then\r
- Swap lau(x, y), lau(x + 1, y + 1)\r
- humngo h2\r
- Swap lau(x, y), lau(x + 1, y + 1)\r
- If h2 > h1 Then\r
- h1 = h2\r
- If sug = 1 Then cx1 = x: cy1 = y: cx2 = x + 1: cy2 = y + 1\r
- End If\r
- End If\r
-\r
- End If\r
- Next x\r
- Next y\r
- h = h1\r
- 10\r
- sug = sug - 1\r
- 6\r
-End Sub\r
-\r
-Sub compki (m, h, x1, y1)\r
- h1 = 0\r
-\r
- For y = 1 To siz\r
- For x = 1 To siz\r
- Next x\r
- Next y\r
- h = h1\r
-\r
-End Sub\r
-\r
-Sub freet\r
- a$ = InKey$\r
- If a$ = "" Then\r
- Else\r
- If a$ = Chr$(8) Then\r
- If Len(stri$) > 0 Then\r
- stri$ = Left$(stri$, Len(stri$) - 1): GoTo 3\r
- End If\r
- End If\r
- If a$ = Chr$(13) Then\r
- If Len(stri$) > 0 Then\r
- msg stri$, 7\r
- cmd stri$\r
- stri$ = ""\r
- End If\r
- GoTo 3\r
- End If\r
- stri$ = stri$ + a$\r
- 3\r
- Line (400, 468)-(639, 479), 1, BF\r
- prn 405, 469, 14, stri$\r
- End If\r
-End Sub\r
-\r
-Sub getfnt\r
- Screen 13\r
- For a = 0 To 255\r
- If (a > 5) And (a < 17) Then GoTo 2\r
- Locate 1, 1\r
- Print Chr$(a)\r
- 2\r
- For y = 0 To 7\r
- For x = 0 To 7\r
- font(x, y, a) = Point(x, y)\r
- Next x\r
- Next y\r
- Next a\r
-\r
-End Sub\r
-\r
-Sub humngo (h)\r
- npos = npos + 1\r
- h1 = 1000\r
-\r
- For y = siz To 1 Step -1\r
- For x = siz To 1 Step -1\r
- If lau(x, y) = 2 Then\r
- If lau(x - 1, y - 1) = 0 Then\r
- Swap lau(x, y), lau(x - 1, y - 1)\r
- compgo h2\r
- Swap lau(x, y), lau(x - 1, y - 1)\r
- If h2 < h1 Then h1 = h2\r
- End If\r
-\r
- If lau(x + 1, y - 1) = 0 Then\r
- Swap lau(x, y), lau(x + 1, y - 1)\r
- compgo h2\r
- Swap lau(x, y), lau(x + 1, y - 1)\r
- If h2 < h1 Then h1 = h2\r
- End If\r
-\r
-\r
- If (lau(x - 1, y - 1) = 1) And (lau(x - 2, y - 2) = 0) Then\r
- Swap lau(x, y), lau(x - 2, y - 2)\r
- lau(x - 1, y - 1) = 0\r
- humngo h2\r
- lau(x - 1, y - 1) = 1\r
- Swap lau(x, y), lau(x - 2, y - 2)\r
- If h2 - 1 < h1 Then h1 = h2 - 1\r
- End If\r
-\r
- If (lau(x + 1, y - 1) = 1) And (lau(x + 2, y - 2) = 0) Then\r
- Swap lau(x, y), lau(x + 2, y - 2)\r
- lau(x + 1, y - 1) = 0\r
- humngo h2\r
- lau(x + 1, y - 1) = 1\r
- Swap lau(x, y), lau(x + 2, y - 2)\r
- If h2 - 1 < h1 Then h1 = h2 - 1\r
- End If\r
-\r
-\r
-\r
-\r
- End If\r
- Next x\r
- Next y\r
- h = h1\r
-End Sub\r
-\r
-Sub mklau\r
- For y = -1 To siz + 2\r
- For x = -1 To siz + 2\r
- lau(x, y) = -1\r
- Next x\r
- Next y\r
-\r
- For y = 1 To siz\r
- For x = 1 To siz\r
- lau(x, y) = 0\r
- Next x\r
- Next y\r
-\r
- For y = 1 To ri\r
- For x = 1 To siz\r
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then\r
- lau(x, y) = 1\r
- End If\r
- Next x\r
- Next y\r
-\r
- For y = siz - ri + 1 To siz\r
- For x = 1 To siz\r
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then\r
- lau(x, y) = 2\r
- End If\r
- Next x\r
- Next y\r
-\r
-End Sub\r
-\r
-Sub msg (a$, c)\r
- Dim buf(1 To 10000)\r
- For x = 400 To 630 Step 40\r
- Get (x, 8)-(x + 39, 467), buf(1)\r
- Put (x, 0), buf(1), PSet\r
- Next x\r
- Line (400, 460)-(639, 467), 0, BF\r
- prn 405, 460, c, a$\r
-End Sub\r
-\r
-Sub playg\r
- 'GOTO 7\r
- 1\r
- thinkc\r
- show\r
- 7\r
- thinkh\r
- show\r
- GoTo 1\r
-\r
-\r
-End Sub\r
-\r
-Sub prn (x, y, c, a$)\r
- x1 = x\r
- y1 = y\r
- For a = 1 To Len(a$)\r
- b = Asc(Right$(Left$(a$, a), 1))\r
- For y2 = 0 To 7\r
- For x2 = 0 To 7\r
- If font(x2, y2, b) > 0 Then PSet (x2 + x1, y2 + y1), c\r
- Next x2\r
- Next y2\r
- x1 = x1 + 8\r
- Next a\r
-End Sub\r
-\r
-Sub show\r
- For y = 1 To siz\r
- For x = 1 To siz\r
- showr x, y\r
- Next x\r
- Next y\r
-\r
- sp = rs / 2\r
- For x = 1 To siz\r
- prn ((x - 1) * rs + 12 + sp), 2, 10, Chr$(64 + x)\r
- prn ((x - 1) * rs + 12 + sp), siz * rs + 11, 10, Chr$(64 + x)\r
- Next x\r
-\r
- For y = 1 To siz\r
- a$ = Str$(y)\r
- a$ = Right$(a$, Len(a$) - 1)\r
- prn 15 - (Len(a$) * 8), (y - 1) * rs + sp + 7, 10, a$\r
- prn (siz * rs + 16), (y - 1) * rs + sp + 7, 10, a$\r
- Next y\r
-\r
-\r
-End Sub\r
-\r
-Sub showr (x, y)\r
- If (x + y + fi) / 2 = Int((x + y + fi) / 2) Then c = 8 Else c = 7\r
- x1 = (x - 1) * rs + 15\r
- y1 = (y - 1) * rs + 10\r
- Line (x1, y1)-(x1 + rs - 1, y1 + rs - 1), c, BF\r
- If lau(x, y) > 0 Then\r
- sp = rs / 2\r
- If lau(x, y) = 1 Then c1 = 15 Else c1 = 14\r
- Circle (x1 + sp, y1 + sp), sp - 1, c1\r
- Paint (x1 + sp, y1 + sp), c1\r
- End If\r
-End Sub\r
-\r
-Sub start\r
- getfnt\r
- Screen 12\r
- Line (399, 0)-(399, 479), 13\r
- msg "type 'h' for help", 14\r
-\r
- rs = Int(370 / siz)\r
-\r
-\r
-End Sub\r
-\r
-Sub thinkc\r
- msg "computer turn", 14\r
- sug = 0\r
- npos = 0\r
- cx1 = -1\r
-\r
- compgo h\r
- cmd "n"\r
- If cx1 = -1 Then msg "you won!", 10: msg "--------", 10: System\r
-\r
- If h <= -2 Then msg "oh no...", 10\r
- If h = -1 Then msg "oops!", 10\r
- If h = 1 Then msg "yess! I will eat soon!", 10\r
- If h >= 2 Then msg "HA HA HA YOU ARE IN TROUBLE!", 10\r
-\r
-\r
- If Abs(cx1 - cx2) = 2 Then\r
- cx3 = (cx1 + cx2) / 2\r
- cy3 = (cy1 + cy2) / 2\r
- lau(cx3, cy3) = 0\r
- showr cx3, cy3\r
- End If\r
-\r
- Swap lau(cx1, cy1), lau(cx2, cy2)\r
- showr cx1, cy1\r
- showr cx2, cy2\r
-\r
-End Sub\r
-\r
-Sub thinkh\r
- msg "your turn", 14\r
- 5\r
- freet\r
- If humx1 = 0 Then GoTo 5\r
- Swap lau(humx2, humy2), lau(humx1, humy1)\r
- showr humx1, humy1\r
- showr humx2, humy2\r
- If Abs(humx1 - humx2) = 2 Then\r
- cx3 = (humx1 + humx2) / 2\r
- cy3 = (humy1 + humy2) / 2\r
- lau(cx3, cy3) = 0\r
- showr cx3, cy3\r
- End If\r
-\r
- humx1 = 0\r
-End Sub\r
+' Checkers game (unfinished)
+' by Svjatoslav Agejenko 2001
+
+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
projects / qbasicapps.git / commitdiff