Noughts And Crosses -- Olympic

User projects written in or related to FreeBASIC.
Post Reply
dodicat
Posts: 8007
Joined: Jan 10, 2006 20:30
Location: Scotland

Noughts And Crosses -- Olympic

Post by dodicat »

Tic-Tac-Toe thing.
You are the cross, your box is the nought.

Code: Select all


'About 450 lines of code, but it is a graphical (GUI ish) i.e. mouse driven.
'I have made provision for the player to beat the computer now and then.
'To fix the bug in version 1.08.0 the next 21 lines must be included
#if __FB_VERSION__ = "1.08.0"
   '' remove new 1.08.0 SCREENCONTROL gfx API entry points
   #undef screencontrol
   #undef screencontrol
   #undef screencontrol

   '' add back the 1.07.x and earlier SCREENCONTROL gfx API entry points
   extern "rtlib"
      declare sub ScreenControl overload alias "fb_GfxControl_s" _
         ( _   
            byval what as long, byref param as string = "" _
         )
      declare sub ScreenControl alias "fb_GfxControl_i" _
         ( _
            byval what as long, _
            byref param1 as integer = 0, _
            byref param2 as integer = 0, _
            byref param3 as integer = 0, _
            byref param4 as integer = 0 _
         )
   end extern
#endif


Type box
    As long x,y           
    As long wide,high,index
    Dim As ulong colour
    As String caption
    Declare Sub show       
    Declare Sub NewCaption(s As String)
    Declare Constructor
    Declare Constructor(x As long,y As long,wide As long,_
    high As long,index As long,colour As ulong,caption As String)
End Type
Constructor box
End Constructor
Constructor box(x As long,y As long,wide As long,_
high As long,index As long,colour As ulong,caption As String)
this.x=x
this.y=y
this.wide=wide
this.high=high
this.index=index
this.colour=colour
this.caption=caption
End Constructor
'ALL PROCEDURES:
Declare Function inside(B As box,px As long,py As long) As long
Declare Sub make_frame_image(im As ulong Pointer)
Declare Sub setup_grid(boxes() As box,cellsacross As long,cellsdown As long,xp As long,yp As long,w As long,h As long)
Declare Function all_clicked(b() As box) As long
Declare Sub OnCLICK(a() As box,b As box)
Declare Sub refresh_screen(b() As box,f1 As long=0,f2 As long=0)
Declare Function Get_Mouse_Events(boxes() As box) As long
Declare Sub thickline(x1 As long,y1 As long,x2 As long,y2 As long,thickness As Single,colour As ulong,im As Any Pointer=0)
Declare Sub lineto(x1 As long,y1 As long,x2 As long,y2 As long,l As long,th As Single,col As ulong,im As Any Pointer=0)
Declare Sub thickcircle(x As long,y As long,rad As long,th As Single,col As ulong,im As Any Pointer=0)
Declare Sub startup(b() As box)
Declare Sub get_computer_events(b() As box)

Declare Sub finish
'Macro used by more than one procedure
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
'===============  RUN  ============================
Screen 19,32',1,16
Color ,Rgb(233,236,216)              'background colour
windowtitle string(100," ")+"Noughts and crosses"
'Globals:
Dim Shared As ulong Pointer frame
Dim Shared As long computer,player
Dim Shared As String msg1,msg2,message
message="In Play"
msg1="Computer Start"
msg2="Player Start"
'Custom Frame
frame=Imagecreate(800,600)

Dim  As box boxes(0 To 9)

setup_grid(boxes(),3,3,175,85,150,150)
make_frame_image(frame)

Do
    If player=0 And computer=0 Then
        startup(boxes())
    End If
   
    If player  Then
        Get_Mouse_Events(boxes())
    End If
   
    If computer Then
        get_computer_events(boxes())
    End If
   
    If all_clicked(boxes()) Then get_computer_events(boxes())
Loop Until Inkey=Chr(27)
finish

Sub box.show
    Line(this.x,this.y)-(this.x+this.wide,this.y+this.high),this.colour,bf
    Line(this.x,this.y)-(this.x+this.wide,this.y+this.high),Rgb(200,200,200),b
    ''Draw String(this.x+.5*this.wide-4*Len(this.caption),this.y+(.5*this.high-4)),this.caption,Rgb(0,0,0)
    If this.index=0 Then
        Draw String(this.x+.5*this.wide-4*Len(this.caption),this.y+.5*this.high-6),this.caption,Rgb(0,0,0)
    End If
End Sub
Sub box.NewCaption(s As String)
    Var cx=(this.x+this.x+this.wide)/2
    Var cy=(this.y+this.y+this.high)/2
    If s="X" Then
        For k As long=20 To 0 Step -1
            lineto(cx,cy,this.x,this.y,50,k,Rgb(50+10*k,5*k,0),frame)
            lineto(cx,cy,this.x+this.wide,this.y+this.high,50,k,Rgb(50+10*k,5*k,0),frame)
            lineto(cx,cy,this.x,this.y+this.high,50,k,Rgb(50+10*k,5*k,0),frame)
            lineto(cx,cy,this.x+this.wide,this.y,50,k,Rgb(50+10*k,5*k,0),frame)
        Next k
    Else
        For k As long=20 To 0 Step -1
            thickcircle(cx,cy,40,k,Rgb(50+10*k,5*k,0),frame)
        Next k
    End If
End Sub
Sub get_computer_events(b() As box)
    #define other(n)  b(n).caption<>"0" And b(n).caption<>"C"
    #define another(n) b(n).caption="0"
    #define rr(f,l) (Rnd*((l)-(f))+(f))
    Dim As long flag,i,k,Cwin,Pwin,NoWin
    Static As long firstclick
    var chance="001100"
    dim as long ch
    'horiz player finish
    For x As long=1 To 3
        If b(1+k).caption="0" And b(2+k).caption="0" And another((3+k)) Then b(3+k).Caption="0":Pwin=1:Goto fin
        If b(2+k).caption="0" And b(3+k).caption="0" And another((1+k))Then b(1+k).Caption="0":Pwin=1=1:Goto fin
        If b(1+k).caption="0" And b(3+k).caption="0" And another((2+k))Then b(2+k).Caption="0":Pwin=1:Goto fin
        k=k+3
    Next x
    k=0
    'vert player finish
    For x As long=1 To 3
        If b(1+k).caption="0" And b(4+k).caption="0" And another((7+k)) Then b(7+k).Caption="0":Pwin=1:Goto fin
        If b(4+k).caption="0" And b(7+k).caption="0" And another((1+k))Then b(1+k).Caption="0":Pwin=1:Goto fin
        If b(1+k).caption="0" And b(7+k).caption="0" And another((4+k))Then b(4+k).Caption="0":Pwin=1:Goto fin
        k=k+1
    Next x
    k=0
    'player finish main diag
    If b(1+k).caption="0" And b(5+k).caption="0" And another((9+k)) Then b(9+k).Caption="0":Pwin=1:Goto fin
    If b(1+k).caption="0" And b(9+k).caption="0" And another((5+k))Then b(5+k).Caption="0":Pwin=1:Goto fin
    If b(5+k).caption="0" And b(9+k).caption="0" And another((1+k))Then b(1+k).Caption="0":Pwin=1:Goto fin
    'player finish other diag
    If b(7+k).caption="0" And b(5+k).caption="0" And another((3+k)) Then b(3+k).Caption="0":Pwin=1:Goto fin
    If b(5+k).caption="0" And b(3+k).caption="0" And another((7+k))Then b(7+k).Caption="0":Pwin=1:Goto fin
    If b(7+k).caption="0" And b(3+k).caption="0" And another((5+k))Then b(5+k).Caption="0":Pwin=1:Goto fin
   
    'horiz computer finish
    For x As long=1 To 3
        If b(1+k).caption="C" And b(2+k).caption="C" And other((3+k)) Then b(3+k).Caption="C":Cwin=1:Goto fin
        If b(2+k).caption="C" And b(3+k).caption="C" And other((1+k))Then b(1+k).Caption="C":Cwin=1:Goto fin
        If b(1+k).caption="C" And b(3+k).caption="C" And other((2+k))Then b(2+k).Caption="C":Cwin=1:Goto fin
        k=k+3
    Next x
    k=0
    'vert computer finish
    For x As long=1 To 3
        If b(1+k).caption="C" And b(4+k).caption="C" And other((7+k)) Then b(7+k).Caption="C":Cwin=1:Goto fin
        If b(4+k).caption="C" And b(7+k).caption="C" And other((1+k))Then b(1+k).Caption="C":Cwin=1:Goto fin
        If b(1+k).caption="C" And b(7+k).caption="C" And other((4+k))Then b(4+k).Caption="C":Cwin=1:Goto fin
        k=k+1
    Next x
    k=0
    'computer finish main diag
    If b(1+k).caption="C" And b(5+k).caption="C" And other((9+k)) Then b(9+k).Caption="C":Cwin=1:Goto fin
    If b(1+k).caption="C" And b(9+k).caption="C" And other((5+k))Then b(5+k).Caption="C":Cwin=1:Goto fin
    If b(5+k).caption="C" And b(9+k).caption="C" And other((1+k))Then b(1+k).Caption="C":Cwin=1:Goto fin
    'computer finish other diag
    If b(7+k).caption="C" And b(5+k).caption="C" And other((3+k)) Then b(3+k).Caption="C":Cwin=1:Goto fin
    If b(5+k).caption="C" And b(3+k).caption="C" And other((7+k))Then b(7+k).Caption="C":Cwin=1:Goto fin
    If b(7+k).caption="C" And b(3+k).caption="C" And other((5+k))Then b(5+k).Caption="C":Cwin=1:Goto fin
   
    'block horizontals
    For x As long=1 To 3
        If b(1+k).caption="0" And b(2+k).caption="0" And other((3+k)) Then b(3+k).Caption="C":flag=1:Goto fin
        If b(2+k).caption="0" And b(3+k).caption="0" And other((1+k))Then b(1+k).Caption="C":flag=1:Goto fin
        If b(1+k).caption="0" And b(3+k).caption="0" And other((2+k))Then b(2+k).Caption="C":flag=1:Goto fin
        k=k+3
    Next x
    k=0
    'block verticals
    For x As long=1 To 3
        If b(1+k).caption="0" And b(4+k).caption="0" And other((7+k)) Then b(7+k).Caption="C":flag=1:Goto fin
        If b(4+k).caption="0" And b(7+k).caption="0" And other((1+k))Then b(1+k).Caption="C":flag=1:Goto fin
        If b(1+k).caption="0" And b(7+k).caption="0" And other((4+k))Then b(4+k).Caption="C":flag=1:Goto fin
        k=k+1
    Next x
    k=0
    'block main diag
    If b(1+k).caption="0" And b(5+k).caption="0" And other((9+k)) Then b(9+k).Caption="C":flag=1:Goto fin
    If b(1+k).caption="0" And b(9+k).caption="0" And other((5+k))Then b(5+k).Caption="C":flag=1:Goto fin
    If b(5+k).caption="0" And b(9+k).caption="0" And other((1+k))Then b(1+k).Caption="C":flag=1:Goto fin
    'block other diag
    If b(7+k).caption="0" And b(5+k).caption="0" And other((3+k)) Then b(3+k).Caption="C":flag=1:Goto fin
    If b(5+k).caption="0" And b(3+k).caption="0" And other((7+k))Then b(7+k).Caption="C":flag=1:Goto fin
    If b(7+k).caption="0" And b(3+k).caption="0" And other((5+k))Then b(5+k).Caption="C":flag=1:Goto fin
   
    If firstclick=0 Then
        firstclick=1
       var st="1379"
       dim as long i=rr(0,3)
    If Valint(b(5).caption)=0  and b(5).caption <> "C" Then b(st[i]-48).caption="C":Goto fin
       
    End If
   
     ch=rr(0,5)
    if chance[ch]-48=1 then
    If Valint(b(5).caption)<>0 Then b(5).caption="C":Goto fin
    end if
    If all_clicked(b()) Then Nowin=1:Goto fin
    If flag=0 Then
        Randomize
        Do
            i=rr(1,9)
            If Valint(b(i).caption) <> 0  Then b(i).caption="C":Exit Do
        Loop 
    End If
    fin:
    If Cwin=1 Or Pwin=1 Or NoWin=1 Then
        Dim As long mx,my,mb
        dim as integer x,y
        screencontrol 0,x,y
        for z as single=0 to 8*atn(1) step .001
            dim as integer xx=x+100*cos(z)
            dim as integer yy=y+100*sin(z)
            screencontrol 100,xx,yy
        next z
        screencontrol 100,x,y
        If Cwin=1 Then Message="You Loose"
        If Pwin=1 Then Message="You WIN"
        If Nowin=1 Then Message="DRAW"
        
        cwin=0:k=0:pWin=0:Nowin=0:firstclick=0'i
        Do
            Getmouse mx,my,,mb
            If inside(b(0),mx,my) And mb=1 Then finish
          
            Var ic=incircle(500,55,20,mx,my)
            If incircle(500,55,20,mx,my) And mb=1 Then Exit Do
            refresh_screen(b(),ic)
        Loop Until Inkey=chr(27)
        For z As long=1 To Ubound(b)
            b(z).caption=Str(b(z).index)
        Next z
        Imagedestroy frame
        frame=Imagecreate(800,600)
        make_frame_image(frame)
        computer=0:player=0
        Exit Sub
    End If
    player=1:computer=0
End Sub

Sub startup(b() As box)
    message="In Play"
    Dim As long mx,my,mb
    Getmouse mx,my,,mb
   
    For n As long=0 To Ubound(b)
        If inside(b(n),mx,my) And mb=1 Then
            If b(n).index=0 Then
                finish
            End If
        End If
        b(0).colour=Rgb(200,0,0)
    Next n
    Dim As long f1,f2
    If incircle(80,230,10,mx,my) Then
        f1=1:f2=0
        If mb=1 Then computer=1:player=0
    End If
    If incircle(670,230,10,mx,my) Then
        f1=0:f2=1
        If mb=1 Then player=1:computer=0
    End If
    refresh_screen(b(),f1,f2)
End Sub
Sub thickcircle(x As long,y As long,rad As long,th As Single,col As ulong,im As Any Pointer=0)
    Circle(x,y),rad+th/2,col
    Circle(x,y),rad-th/2,col
    Paint(x,y+rad),col,col
End Sub

Sub thickline(x1 As long,_
    y1 As long,_
    x2 As long,_
    y2 As long,_
    thickness As Single,_
    colour As ulong,_
    im As Any Pointer=0)
    Dim p As ulong=Rgb(255, 255, 255)
    If thickness<2 Then
        Line(x1,y1)-(x2,y2),colour
    Else               
        Dim As Double s,h,c
        h=Sqr((x2-x1)^2+(y2-y1)^2) 
        If h=0 Then h=1e-6
        s=(y1-y2)/h               
        c=(x2-x1)/h                 
        For x As long=1 To 2
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
            Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
            Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
            Paint im,((x1+x2)/2, (y1+y2)/2), p, p
            p=colour
        Next x
    End If
End Sub
Sub lineto(x1 As long,y1 As long,x2 As long,y2 As long,l As long,th As Single,col As ulong,im As Any Pointer=0)
    Dim As long diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
    Dim As Single nx=diffx/ln,ny=diffy/ln
    thickline(x1,y1,(x1+l*nx),(y1+l*ny),th,col,im)
End Sub


Function inside(B As box,px As long,py As long) As long
    Return (px>B.x)*(px<(B.x+B.wide))*(py>B.y)*(py<(B.y+B.high))
End Function
Sub make_frame_image(im As ulong Pointer)
    #macro map(a,b,x,d,c)
    ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    #endmacro
    #macro logo(sx,sy,rad)
For k As Single=-rad/10 To rad/10 Step .5:Circle im,(sx,sy),rad+k,Rgb(15,118,155):Next
For k As Single=-rad/10 To rad/10 Step .5:Circle im,(sx+1.3*rad,sy+rad),rad+k,Rgb(230,193,78),2.,1.7:Next
For k As Single=-rad/10 To rad/10 Step .5:Circle im,(sx+2*1.3*rad,sy),rad+k,Rgb(21,3,0),3.25,3.05:Next
For k As Single=-rad/10 To rad/10 Step .5:Circle im,(sx+3*1.3*rad,sy+rad),rad+k,Rgb(26,143,76),2,1.8:Next
For k As Single=-rad/10 To rad/10 Step .5:Circle im,(sx+4*1.3*rad,sy),rad+k,Rgb(200,63,87),3.25,3.05:Next
#endmacro
    For k As long=0 To 50
        Var r=map(0,50,k,233,193-20)
        Var g=map(0,50,k,236,153-20)
        Var b=map(0,50,k,216,19-19)
        Line im,(0+k,20+k)-(800-k,600-k),Rgb(r,g,b),b
    Next k
    For k As long=0 To 20
        Var r=map(0,20,k,250,0)
        Var g=map(0,20,k,250,0)
        Var b=map(0,20,k,250,255)
        Line im,(0,k)-(780,k),Rgb(r,g,b)',bf
    Next k
    logo(60,8,5)
    logo(380,8,5)
    logo(720,8,5)
End Sub
Sub setup_grid(boxes() As box,cellsacross As long,cellsdown As long,xp As long,yp As long,w As long,h As long)
    Dim As long index
    For y As long=yp To yp+h*(cellsdown-1) Step h
        For x As long=xp To xp+w*(cellsacross-1)   Step w
            index=index+1
            boxes(index)=Type<box>(x,y,w,h,index,Rgb(133,136,116),Str(index))
        Next x
    Next y
    boxes(0)=Type<box>(780,-2,20,24,0,Rgb(200,0,0),"X")
End Sub

Function all_clicked(b() As box) As long
    Dim As long sum
    For z As long=1 To Ubound(b)
        sum=sum+Valint(b(z).caption)
    Next z
    If sum<=0 Then Return -1
End Function

Sub OnCLICK(a() As box,b As box)
    If b.caption="0" Then Exit Sub
    If b.caption="C" Then Exit Sub
    If b.caption <> "C" Then b.caption="0"
    If b.index=0 Then finish
    player=0:computer=1
End Sub

Sub refresh_screen(b() As box,f1 As long=0,f2 As long=0)
    Screenlock:Cls
    For n As long=0 To Ubound(b)
        b(n).show 'draw boxes
        If b(n).caption="0" Then b(n).NewCaption("X")
        If b(n).caption="C" Then b(n).NewCaption("O")
    Next n
    Put(0,0),frame,trans
    Draw String (390,50),message,Rgb(0,0,0)
    If message <>"In Play" Then
        Circle(500,55),20,Rgb(255,20,255),,,,f
        If f1=-1 Then Circle(500,55),20,Rgb(202,200,200),,,,f
        Draw String(480,50),"Click",Rgb(0,0,0)
    End If
    If computer=0 And player=0 Then
        Draw String (60,200),msg1,Rgb(0,0,0)
        Circle(80,230),10,Rgb(0,0,0)
        Circle(80,230),5,Rgb(100,100,100),,,,f
        If f1=1 Then Circle(80,230),10,Rgb(200,0,0),,,,f
        Draw String (650,200),msg2,Rgb(0,0,0)
        Circle(670,230),10,Rgb(0,0,0)
        Circle(670,230),5,Rgb(100,100,100),,,,f
        If f2=1 Then Circle(670,230),10,Rgb(200,0,0),,,,f
    End If
    Screenunlock:Sleep 1,1
End Sub

Function Get_Mouse_Events(boxes() As box) As long
    Static released As long
    Static pressed As long
    Dim As long mousex,mousey,mousebutton ,x,y
    Getmouse mousex,mousey,,mousebutton
    Dim As box bar=Type<box>(0,0,780,50,0,0,"")
   
    refresh_screen(boxes())
    For n As long=0 To Ubound(boxes)
        If inside(boxes(n),mousex,mousey)  Then
            If released Then
                boxes(n).colour=Rgb(120,123,103) 
                If n=0 Then boxes(0).colour=Rgb(255,0,0)
            End If
            If mousebutton=1 Then
                If released Then OnCLICK(boxes(),boxes(n))
                Exit For
            End If
        Else
            boxes(n).colour=Rgb(133,136,116)
            If n=0 Then boxes(0).colour=Rgb(200,0,0)
        End If
    Next n
    If mousebutton=0 Then released=1 Else released=0 'clean clicks
    Return 0
End Function
Sub finish
    Screenunlock
    Imagedestroy frame
    End
End Sub



  
Last edited by dodicat on Jun 12, 2021 14:18, edited 1 time in total.
dodicat
Posts: 8007
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Noughts And Crosses -- Olympic

Post by dodicat »

I've updated the game to make it more difficult to win.
Roland Chastain
Posts: 1008
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Noughts And Crosses -- Olympic

Post by Roland Chastain »

Very nice, dodicat !

I like what you make with colors. I have to study your code, to see how you obtain these effects.
dodicat
Posts: 8007
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Noughts And Crosses -- Olympic

Post by dodicat »

Hi Roland Chastain
Thanks for the feedback on this.
To simplify colour mapping, I have made up a little #define macro
This is for linear mapping from one range into another.
It is very simple in essence, but it saves messing around if you want to map a certain variable in a range to a colour value in 0 to 255.
Example:
It must be pretty hot in Mali just now, up here it should at least be WARM, but leaden skies, day after day, are a blight to our Summer.

Code: Select all

 
#define map(a,b,x,d,c) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define length(px,py,x,y) sqr(((px)-(x))*((px)-(x))+((py)-(y))*((py)-(y)))
Screenres 800,600,32
Dim As Integer maxdist=Sqr(400^2+300^2) 'maximum distance from screen centre to a point
'get all points on the screen
For x As Integer =0 To 800
    For y As Integer =0 To 600
        Var cx=x
        If x=400 Then cx=401 '(function sin(theta)/theta is infinity at x=400)
        Var theta=(400-cx)/30
        Var dist=length(400,300,x,y) 'distance of (x,y) from the screen centre
        'as dist ranges between 0 and maxdist, value ranges between 50 and 255 ~colour value
        Var value=map(0,maxdist,dist,50,255)
        If y<500-80*Sin(theta)/theta Then 
            Pset(x,y),Rgb(value,value,value) 'sky
        Else
            value=map(0,maxdist,dist,150,20)
            Pset(x,y),Rgb(0,value,0)   'hills
        End If
    Next y
Next x
Sleep
 
Roland Chastain
Posts: 1008
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Noughts And Crosses -- Olympic

Post by Roland Chastain »

Beautiful code. There are several things in it I was looking for. Thank you for this, dodicat !
MrSwiss
Posts: 3910
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Noughts And Crosses -- Olympic

Post by MrSwiss »

@dodicat,

you may want to change the following line:

Code: Select all

#if __FB_VERSION__ = "1.08.0"
-- to --

Code: Select all

#if __FB_VERSION__ >= "1.08.0"
To also include later versions; e.g. "1.08.1", "1.09.0" e.t.c. (just more versatile).
Post Reply