FreeBasic

Реализация знаменитой игры палочки, только вместо палочек выступают кружки. Для тех кто не знаком с этой игрой:  соперники по очереди могут убирать не более 3 кружков, тот кому достанется последний проиграл. Игра ведется с компьютером. Кол-во кружков всегда разное. Управление мышкой.
Платформы: Windows , Linux.
Автор: Станислав Будинов, создано 2011 году.

#INCLUDE "fbgfx.bi"

Using FB
Randomize Timer

Screenres 320,240

Windowtitle "Circles"

Type D
    MASS(35) As Integer

    Num As Integer

    Lw As Integer=25

    Lh As Integer=1

End Type

Type Koord
    x As Integer

    y As Integer

End Type


Dim Shared Dp As D
Dim Shared K As EVENT
Dim Shared EvM As Koord
'Случайное число
Sub RND_()
    Dp.Num=Int(Rnd*20)+15

    Erase(Dp.MASS)
End Sub

' проверка на самое большое кол-во выделенных кружков
Function CheckFull() As Integer

    Dim As Integer R
    For a As Integer=1 To Dp.num
        If Dp.MASS(a)=1 Then

            R+=1

        Endif
    Next

    If R=3 Then

        Return 1

    Elseif R=0 Then

        Return 2

    Endif
End Function

' Рисование анимации ожидания
Sub wait_
    For v As Integer=1 To 2

        For a As Integer=1 To 10

            Circle (122, 24), a\2,a,,,,F
            Circle (200, 24), a\2,a,,,,F
            Sleep(100)
        Next

    Next

    Circle (122, 24), 5,0,,,,F
    Circle (200, 24), 5,0,,,,F
End Sub

'Рисование кнопки
Sub But(butF As Integer)
    Dim As Integer a,b
    If butF=0 Then

        a=3:b=1

    Else

        a=5:b=4

    Endif
    Line (270, 210)-(300, 225), a, bf
    Line (271, 211)-(299, 224), b, bf
    Draw String (278, 214), "Ok"
End Sub

'Рисование кружков
Sub drC()
    For n As Integer=1 To Dp.Num
        Select Case Dp.MASS(n)
            Case 0

                Circle (Dp.Lw, Dp.Lh*50), 10,2,,,,F
            Case 1

                Circle (Dp.Lw, Dp.Lh*50), 10,6,,,,F
            Case 2

                Circle (Dp.Lw, Dp.Lh*50), 10,0,,,,F
        End Select

        Dp.Lw+=30

        If Dp.Lw > 300 Then

            Dp.Lh+=1: Dp.Lw=25

        Endif
    Next

    Dp.Lw=25

    Dp.Lh=1

End Sub

' Рисование рамки и заголовка
Sub EnotherDraw()
    Draw "BM 5,5 R310 D230 L310 U230"
    Draw String (135, 20), "Circles"
End Sub

' Удаление выбранных ячеек
Sub ClearSel()
    For a As Integer=1 To Dp.num
        If Dp.MASS(a)=1 Then

            Dp.MASS(a)=2

        Endif
    Next

End Sub

' Запуск новой игры
Sub newGame()
    RND_()
    drC()
    EnotherDraw()
    But(0)
End Sub

'Окно выигрыша или проигрыша
Sub PV(st As String)
    Cls

    Draw String (45, 100),ST & " Want to play again?"
    Draw String (97, 130),"Y - Yes , N - No"
    Do

        If Multikey(SC_Y) Then

            Cls

            newGame()
            Exit Sub

        Elseif Multikey(SC_N) Then

            End

        Endif
    Loop

End Sub

'Проверка имеющихся ячеек
Sub Check(RR() As Integer)
    Dim As Integer R
    For a As Integer=1 To Dp.num
        If Dp.MASS(a)=0 Then

            R+=1

            RR(R)=a
        Endif
    Next

    RR(0)=R
End Sub

' Проверка на проигрыш
Function finish() As Integer

    For a As Integer=1 To Dp.num
        If Dp.MASS(a)<>2 Then Return 1

    Next

End Function

'Ход компьютера
Sub AI()
    Setmouse(,,0)
    Sleep(2000,1)
    Dim As Integer RR(35),R1,R2
    Check(RR(0))
    If  RR(0)-1=1 Or RR(0)-1=5 Or RR(0)-1=9 Or RR(0)-1=13 Or RR(0)-1=17 Then R2=1

    If  RR(0)-2=1 Or RR(0)-2=5 Or RR(0)-2=9 Or RR(0)-2=13 Or RR(0)-2=17 Then R2=2

    If  RR(0)-3=1 Or RR(0)-3=5 Or RR(0)-3=9 Or RR(0)-3=13 Or RR(0)-3=17 Then R2=3

    If R2<>0 Then

        For a As Integer=1 To R2
            R1=Int(Rnd*RR(0))+1

            Dp.MASS(RR(R1))=2

            Erase(RR)
            Check(RR(0))
        Next

    Else

        For a As Integer=1 To Int(Rnd*3)+1

            R1=Int(Rnd*RR(0))+1

            Dp.MASS(RR(R1))=2

            If finish()<>1 Then

                PV("You won!")
                Exit For

            Endif
            Erase(RR)
            Check(RR(0))
        Next

    Endif
    drC()
    Setmouse(,,1)
End Sub

' Распознавание кружка в строке
Function RK() As Integer

    Dim As Integer xx=15,yy=35

    For a As Integer=1 To 10

        If EvM.x>xx And EvM.x<yy Then
            Return a
        Endif
        xx+=30:yy+=30

    Next

End Function


' определение события в кнопке или в кружках и определение кружка
Sub Ev()
    If EvM.x>270 And EvM.x<300 And EvM.y>210 And EvM.y<225 Then

        If CheckFull=2 Then Exit Sub

        But(1)
        ClearSel()
        If finish()=1 Then

            Threadcreate(Cast(Any Ptr,@wait_()))
            Threadcreate(Cast(Any Ptr,@AI()))
        Else

            PV("You lost!")
        Endif
    Endif
    Dim As Integer xx=40,yy=60

    For a As Integer=1 To 4

        If EvM.y>xx And EvM.y<yy Then

            If CheckFull=1 Then

                If Dp.MASS(RK+(a-1)*10)<>1 Then

                    Exit Sub

                Endif
            Endif
            If RK<>0 Then

                Dp.MASS(RK+(a-1)*10)=Dp.MASS(RK+(a-1)*10) Xor 1

            Endif
        Endif
        xx+=50:yy+=50

    Next

End Sub

newGame()
Do

    If (Screenevent(@K)) Then

        If K.type=EVENT_MOUSE_BUTTON_PRESS Then

            If K.button=1 Then

                Getmouse(EvM.x,EvM.y)
                Ev()
                drC()
                EnotherDraw()
            Endif
        Elseif K.type=EVENT_MOUSE_BUTTON_release Then

            But(0)
        Endif
    Endif
    Sleep(1)
Loop Until K.type=EVENT_WINDOW_CLOSE