Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Оценить эту запись

Крестики-нолики

Запись от The trick размещена 12.12.2013 в 01:59
Обновил(-а) The trick 26.06.2015 в 22:38

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
Option Explicit
 
' Крестики-нолики
' © Кривоус Анатолий Анатольевич (The trick), 2013
 
Dim i As Long, j As Long, r As Long, c As Long, dd As Boolean, di As Boolean, ct As Long, pass As Long
Dim dx As Single, dy As Single
Dim Fld() As Byte '  0 - пусто, 1 - крестик, 4 - нолик
 
Private Sub Win(ByVal Value As Long)
    MsgBox "Победили " & IIf(Value = 3, "крестики", "нолики")
    ReDim Fld(2, 2): ct = 0: r = 0: c = 0: dd = False: di = False: pass = 0: Redraw: If Rnd > 0.5 Then NextPass
End Sub
Private Sub NextPass()
    Dim sr As Byte, sc As Byte, sd As Byte, si As Byte
    pass = pass + 1
    If NewDirect = 1 Then
        For i = 0 To 2
            If r Then If Fld(i, r - 1) = 0 Then Call SetPass(i, r - 1, 1): Exit For
            If c Then If Fld(c - 1, i) = 0 Then Call SetPass(c - 1, i, 1): Exit For
            If dd Then If Fld(i, i) = 0 Then Call SetPass(i, i, 1): Exit For
            If di Then If Fld(2 - i, i) = 0 Then Call SetPass(2 - i, i, 1): Exit For
        Next
    End If
    For i = 0 To 2: For j = 0 To 2
            sr = sr + Fld(j, i): sc = sc + Fld(i, j)
        Next
        sd = sd + Fld(i, i): si = si + Fld(2 - i, i)
        If sr = 12 Or sr = 3 Then Me.Line (0, i * dy + dy / 2)-Step(Me.ScaleWidth, 0), vbRed: Win sr: Exit Sub
        If sc = 12 Or sc = 3 Then Me.Line (i * dx + dx / 2, 0)-Step(0, Me.ScaleHeight), vbRed: Win sc: Exit Sub
        If sd = 12 Or sd = 3 Then Me.Line (0, 0)-Step(Me.ScaleWidth, Me.ScaleHeight), vbRed: Win sd: Exit Sub
        If si = 12 Or si = 3 Then Me.Line (0, Me.ScaleHeight)-(Me.ScaleWidth, 0), vbRed: Win si: Exit Sub
        sr = 0: sc = 0
    Next
    If pass >= 5 Then
        pass = 0
        MsgBox "Íè÷üÿ": ReDim Fld(2, 2): ct = 0: r = 0: c = 0: dd = False: di = False: Redraw
        Exit Sub
    End If
End Sub
Private Sub SetPass(ByVal X As Long, ByVal Y As Long, ByVal Value As Byte)
    Fld(X, Y) = Value
    Redraw
End Sub
Private Sub Redraw()
    Dim Value As Byte
    dx = Me.ScaleWidth / 3: dy = Me.ScaleHeight / 3
    Me.Cls: Me.DrawWidth = 1
    Me.Line (dx, -1)-Step(dx, Me.ScaleHeight + 1), RGB(200, 200, 200), B
    Me.Line (-1, dy)-Step(Me.ScaleWidth + 1, dy), RGB(200, 200, 200), B
    Me.DrawWidth = 4
    For i = 0 To 2: For j = 0 To 2
        Value = Fld(i, j)
        Select Case Value
        Case 1: Me.Line (i * dx + 10, j * dy + 10)-Step(dx - 20, dy - 20), &HA0: _
                Me.Line (i * dx + dx - 10, j * dy + 10)-Step(20 - dx, dy - 20), &HA0
        Case 4: Me.Circle (i * dx + dx / 2, j * dy + dy / 2), dx / 2 - 10, &HA00000, , , dy / dx
        End Select
    Next: Next
End Sub
Private Function NewDirect() As Long
    Dim sr As Byte, sc As Byte, sd As Byte, si As Byte, ir As Long, ic As Long, id As Long, ii As Long, p As Long
    NewDirect = 2
    For p = 0 To 1: For i = 0 To 2: For j = 0 To 2
            sr = sr + Fld(j, i): sc = sc + Fld(i, j)
            ir = IIf(Fld(j, i) = 0, j, ir): ic = IIf(Fld(i, j) = 0, j, ic)
        Next
        sd = sd + Fld(i, i): si = si + Fld(2 - i, i)
        id = IIf(Fld(i, i) = 0, i, id): ii = IIf(Fld(2 - i, i) = 0, i, ii)
        If sr = p * 6 + 2 Then Call SetPass(ir, i, 1): Exit Function
        If sc = p * 6 + 2 Then Call SetPass(i, ic, 1): Exit Function
        If i = 2 Then
            If sd = p * 6 + 2 Then Call SetPass(id, id, 1): Exit Function
            If si = p * 6 + 2 Then Call SetPass(2 - ii, ii, 1): Exit Function
        End If
        sr = 0: sc = 0
    Next: si = 0: sd = 0: id = 0: ii = 0: Next
    NewDirect = 1
    If r Then If (Fld(0, r - 1) + Fld(1, r - 1) + Fld(2, r - 1)) < 2 Then ct = ct + 1: Exit Function
    If c Then If (Fld(c - 1, 0) + Fld(c - 1, 1) + Fld(c - 1, 2)) < 2 Then ct = ct + 1: Exit Function
    If dd Then If (Fld(0, 0) + Fld(1, 1) + Fld(2, 2)) < 2 Then ct = ct + 1: Exit Function
    If di Then If (Fld(2, 0) + Fld(1, 1) + Fld(0, 2)) < 2 Then ct = ct + 1: Exit Function
    c = 0: r = 0: dd = False: di = False
    For i = 0 To 2
        sc = Fld(i, 0) + Fld(i, 1) + Fld(i, 2): sr = Fld(0, i) + Fld(1, i) + Fld(2, i)
        If sc < 2 Then If c Then If Rnd > 0.5 Then c = i + 1 Else c = c Else c = i + 1
        If sr < 2 Then If r Then If Rnd > 0.5 Then r = i + 1 Else r = r Else r = i + 1
    Next
    If (Fld(0, 0) + Fld(1, 1) + Fld(2, 2)) < 2 Then dd = True
    If (Fld(2, 0) + Fld(1, 1) + Fld(0, 2)) < 2 Then di = True
    ct = 1: If NewDirect = 2 Then Exit Function
    If r > 0 And (Rnd > 0.75 Or Not (c > 0 Or dd Or di)) Then c = 0: dd = False: di = False: Exit Function
    If c > 0 And (Rnd > 0.75 Or Not (r > 0 Or dd Or di)) Then r = 0: dd = False: di = False: Exit Function
    If dd And (Rnd > 0.75 Or Not (c > 0 Or r > 0 Or di)) Then c = 0: r = 0: di = False: Exit Function
    If di Then c = 0: r = 0: dd = False: Exit Function
    NewDirect = 0   ' Нет больше выигрышных ходов
    For i = 0 To 2: For j = 0 To 2
        If Fld(i, j) = 0 Then Call SetPass(i, j, 1): Exit Function
    Next: Next
End Function
Private Sub Form_Load()
    Me.AutoRedraw = True: Me.ScaleMode = vbPixels: Randomize
    ReDim Fld(2, 2)
    If Rnd > 0.5 Then NextPass
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    i = Fix(X / (Me.ScaleWidth / 3)): j = Fix(Y / (Me.ScaleHeight / 3))
    If Fld(i, j) = 0 Then SetPass i, j, 4: NextPass
End Sub
Private Sub Form_Resize()
    Redraw
End Sub
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.png
Просмотров: 435
Размер:	13.3 Кб
ID:	1893  
Вложения
Тип файла: rar TicTacToe.rar (7.8 Кб, 88 просмотров)
Размещено в Без категории
Показов 2143 Комментарии 0
Всего комментариев 0
Комментарии
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.