FreeBasic

В предверии к чемпионату мира по футболу 2014 года , была написана эта анимация. Пример хорош для понимания работы таких конструкции как макросы, Operator, заполнение типов, в общем для людей, изучающих freebasic думаю будет полезно.  

Платформы: Windows, Linux
Автор: dodicat

Type d2
    As Single x,y,z
    Dim As Single mw,ang
End Type

Type line3d
    As d2 v1,v2
End Type

'globals
Dim Shared As Integer xres,yres
Screenres 1000,700,32
Screeninfo xres,yres
Dim Shared As Any Pointer im
im=ImageCreate(xres,yres)
Dim Shared As Uinteger array(xres+1,yres+1)
'_________________________
Operator + (v1 As d2,v2 As d2) As d2
    Return Type<d2>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z,v1.mw+v2.mw,v1.ang+v2.ang)
End Operator

Operator -(v1 As d2,v2 As d2) As d2
    Return Type<d2>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z,v1.mw-v2.mw)
End Operator

Operator *(f As Single,v1 As d2) As d2 'scalar*d2
    Return Type<d2>(f*v1.x,f*v1.y,f*v1.z,f*v1.mw)
End Operator

Operator * (v1 As d2,v2 As d2) As Single 'dot product
    Return v1.x*v2.x+v1.y*v2.y+v1.z+v2.z',v1.mw*v2.mw
End Operator

Operator ^ (v1 As d2,v2 As d2) As d2 'cross product
    Return Type<d2>(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator

#DEFINE dot *
#DEFINE cross ^
#DEFINE length(v) Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
#DEFINE normalize(v) Type<d2>(v.x/length(v),v.y/length(v),v.z/length(v))
#DEFINE rr(f,l) (Rnd*(l-f)+f)

'locals
Dim As Integer n=5
Dim balls(1 To n) As d2
Dim direction(1 To n) As d2
Dim collision(n) As Integer
Dim dt As Single
Dim As d2 SA(1 To 54)
Dim As d2 B(1 To 41)
Dim As line3d linesegments(53)
Dim As Single cxSA,cySA,cxB,cyB
For n As Integer=1 To 54
    Read SA(n).x
    cxSA+=SA(n).x
Next n
For n As Integer=1 To 54
    Read SA(n).y
    cySA+=SA(n).y
Next n

For n As Integer=1 To 41
    Read B(n).x
    cxB+=B(n).x
Next n
For n As Integer=1 To 41
    Read B(n).y
    cyB+=B(n).x
Next n
cxSA=cxSA/54:cySA=cySA/54:
cxB=cxB/41:cyB=cyB/41:

For n As Integer=1 To 53
    linesegments(n).v1=Type<d2>(SA(n).x,SA(n).y)
    linesegments(n).v2=Type<d2>(SA(n+1).x,SA(n+1).y)
Next n
'================================================

Sub drawpolygon(p() As d2, col As Uinteger,im As Any Ptr=0)
    Dim k As Integer=UBound(p)+1
    Dim As Integer index,nextindex
    For n As Integer=1 To Ubound(p)
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        Line im,(p(index).x,p(index).y)-(p(nextindex).x,p(nextindex).y),col
    Next
End Sub

Sub thickline(x1 As Double,_
    y1 As Double,_
    x2 As Double,_
    y2 As Double,_
    thickness As Double,_
    colour As Uinteger,_
    im As Any Pointer=0)
    Dim p As UInteger=RGB(255, 255, 254)
    If thickness<2 Then
        Line im,(x1,y1)-(x2,y2),colour
    Else
        Dim As Double h=Sqr((x2-x1)^2+(y2-y1)^2):If h=0 Then h=1e-6
        Dim As Double s= (y1-y2)/h ,c=(x2-x1)/h
        For x As Integer=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 make_background
    Dim As Integer xres,yres
    Screeninfo xres,yres
    For y As Integer=0 To yres
        Line im,(0,y)-(xres,y),Rgb(0,0,50+y/8)
    Next y
End Sub

Function segmentdistance(l As Line3d,p As d2,Byref ip As d2=Type<d2>(0,0,0)) As Single
    Dim As Single linelength=length((l.v1-l.v2))
    Dim As Single dist= length((1/linelength)*((l.v1-l.v2) cross (p-l.v1)))
    Dim As Single lpf=length((p-l.v2)),lps=length((p-l.v1))
    If lps >= lpf Then
        Var temp=Sqr(lps*lps-dist*dist)/linelength
        If temp>=1 Then temp=1:dist=lpf
        ip=l.v1+temp*(l.v2-l.v1)
        Return dist
    Else
        Var temp=Sqr(lpf*lpf-dist*dist)/linelength
        If temp>=1 Then temp=1:dist=lps
        ip=l.v2+temp*(l.v1-l.v2)
        Return dist
    End If
    Return dist
End Function

Sub draw_balls(b As d2)
    #MACRO rotate(pivotx,pivoty,px,py,a,scale)
        Var Newx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
        Var Newy=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
    #EndMacro
    #MACRO incircle(cx,cy,radius,x,y)
        (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
    #EndMacro
    If b.mw=0 Then b.mw=1
    b.mw=Abs(b.mw)
    Dim As Single dil
    For x As Integer=b.x-40 To b.x+40
        For y As Integer=b.y-40 To b.y+40
            If incircle(b.x,b.y,40,x,y) Then
                rotate(b.x,b.y,x,y,b.ang,dil)
                Var dist=Sqr((b.x-newx)*(b.x-newx)+(b.y-newy)*(b.y-newy))
                dil=(b.mw+(.5-b.mw)*dist/(40*b.mw))
                If incircle(b.x,b.y,(20*b.mw),newx,newy) Then
                    If x<=xres+1 AndAlso y<=yres+1 Then
                        Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),array(Abs(x),Abs(y)),BF
                    End If
                End If
            End If
        Next y
    Next x
End Sub
Function framecounter() As Integer
    Var t1=Timer,t2=t1
    Static As Double t3,frames,answer
    frames+=1
    If (t2-t3)>=1 Then t3=t2:answer=frames:frames=0
    Function= answer
End Function

Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
    fps=framecounter()
    Static As Double timervalue,lastsleeptime
    Dim As Double delta
    Var k=fps-myfps,i=1/myfps
    If Abs(k)>1 Then delta+=i*Sgn(k)
    Var sleeptime=lastsleeptime+(i-Timer+timervalue)*2000+delta
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

Sub FullTime
    Type pt
        As Integer x,y
        As Uinteger col
    End Type
    #MACRO rot(pivot,p,scale)
        Type<pt>(scale*(p.x-pivot.x)+pivot.x,_
        scale*((p.y-pivot.y))+pivot.y)
    #EndMacro
    Dim As Integer _x,_y,cnt
    Screeninfo _x,_y
    Dim As pt a((_x+1)*(_y+1))
    For x As Integer=0 To _x
        For y As Integer=0 To _y
            a(cnt)=Type<pt>(x,y,Point(x,y))
            cnt+=1
        Next y
    Next x
    Dim As pt piv=Type<pt>(_x/2,_y/2)
    For dil As Single=1 To .05 Step -.05
        Screenlock
        Cls
        For n As Integer = 0 To Ubound(a)
            Var temp=rot(piv,a(n),dil)
            Pset(temp.x,temp.y),a(n).col
        Next n
        Screenunlock
    Next dil
    Sleep 1000
    End
End Sub
Sub tessilate(r As Single)
    Dim As Integer xres,yres
    Screeninfo xres,yres
    For y As Integer=0 To yres
        Line im,(0,y)-(xres,y),Rgb(200,y/3,0)
    Next y
    #MACRO _hex(p,r)
        Scope
            Dim flag As Byte
            Dim As Single lastx,lasty
            For z As Single=0 To 360 Step 360/6
                Var x=p.x+r*Cos(z*.0174533)
                Var y=p.y+r*Sin(z*.0174533)
                If flag =1 Then thickline(lastx,lasty,x,y,2,Rgb(y/4,0,255-y/4),im)
                lastx=x
                lasty=y
                flag=1
            Next z
        End Scope
    #EndMacro
    Dim As d2 pt
    Dim As Single x,y,z
    Dim As Integer k=1
    For x =0 To xres Step r+r/2
        z=3*k*r-yres/2
        For y =z To yres Step Sqr(3)*r
            pt=Type<d2>(x,y)
            _hex(pt,r)
        Next y
        k=-k
    Next x
End Sub
'_________draw background  to image then scan sub ________
Sub scan
    Dim As Integer xres,yres
    Screeninfo xres,yres
    tessilate 12
    Put(0,0),im,Pset
    For x As Integer=0 To xres-1
        For y As Integer=0 To yres-1
            array(x,y)=Point(x,y)
        Next y
    Next x
End Sub


Dim As Single seperation,temp

For z As Integer=1 To n 'set positions
    balls(z).x=rr(120,120)+seperation+300
    balls(z).y=rr(150,150)+seperation
    seperation=seperation+100
    balls(z).mw=Sqr(z)
    balls(z).ang=180
Next z
balls(n).mw=1.5
For z As Integer=1 To n 'set speeds
    temp=rr(.5,1.5)
    direction(z).x=temp
    direction(z).y=temp
    direction(z)=1.5*normalize(direction(z))
Next z

' _________Collision macros_____________________
Dim As d2 impulse,impact

#MACRO check_side_collisions()
    For z2 As Integer=1 To n
        #MACRO redirect()
            If collision(z2)=0 Then
                impact=-1*direction(z2)
                dt=impact dot impulse
                direction(z2)=direction(z2)+2*dt*impulse
                collision(z2)=1
            End If
        #EndMacro
        If balls(z2).x<20*balls(z2).mw Then
            impulse=Type<d2>(1,0)
            redirect()
        End If
        If balls(z2).x>xres-20*balls(z2).mw Then
            impulse=Type<d2>(-1,0)
            redirect()
        End If
        If balls(z2).y>yres-20*balls(z2).mw Then
            impulse=Type<d2>(0,-1)
            redirect()
        End If
        If balls(z2).y<20*balls(z2).mw Then
            impulse=Type<d2>(0,1)
            redirect()
        End If
    Next z2
#EndMacro

#MACRO check_ball_to_ball_collisions()
    For xx As Integer=1 To n
        For yy As Integer=1 To n
            If xx<>yy  Then
                If collision(xx)=0 OrElse collision(yy)=0 Then
                    If length((balls(xx)-balls(yy)))<=20*balls(xx).mw+20*balls(yy).mw Then
                        impulse=normalize((balls(xx)-balls(yy)))
                        impact=direction(xx)-direction(yy)
                        dt=(impact dot impulse)
                        Var mxx=balls(xx).mw*balls(xx).mw*balls(xx).mw 'the ball (weights)
                        Var myy=balls(yy).mw*balls(yy).mw*balls(yy).mw
                        direction(xx)=direction(xx)-dt*(2*myy/(mxx+myy))*impulse
                        direction(yy)=direction(yy)+dt*(2*mxx/(myy+mxx))*impulse
                        collision(xx)=1
                        collision(yy)=1
                        balls(xx).ang=balls(xx).ang+length(impact)'dt'5
                        balls(yy).ang=balls(yy).ang-length(impact)'dt'5
                    End If
                End If
            End If
        Next yy
    Next xx

#EndMacro
Dim As d2 impact2
#MACRO check_line_segment_collisions()
    For z3 As Integer=1 To Ubound(linesegments)
        For z2 As Integer=1 To n
            If collision(z2)=0 Then
                If segmentdistance(linesegments(z3),balls(z2),impact2)<20*balls(z2).mw Then
                    impulse=normalize((balls(z2)-impact2))
                    impact=-1*direction(z2)
                    dt=impact dot impulse
                    direction(z2)=direction(z2)+2*dt*impulse
                    collision(z2)=1
                End If
            End If
        Next z2
    Next z3
#EndMacro

#MACRO reset_stuff()
    If callcount Mod 2*n=0 Then collision(z)=0
    If balls(z).ang>180 Then balls(z).ang=balls(z).ang-.05
    If balls(z).ang<180 Then  balls(z).ang=balls(z).ang+.05
#EndMacro

Dim callcount As Integer
scan
make_background
drawpolygon(SA(),Rgb(200,0,0),im)
Paint im,(cxSA,cySA),Rgb(0,100,100),Rgb(200,0,0)
drawpolygon(B(),Rgb(200,200,0),im)
Paint im,(cxB,cyB),Rgb(0,100,0),Rgb(200,200,0)
Dim As Integer fps
Do
    callcount+=1
    If callcount>1e6 Then callcount=0
    check_line_segment_collisions()
    check_side_collisions()
    check_ball_to_ball_collisions()
    Screenlock
    Cls
    Put(0,0),im
    For z As Integer=1 To n
        balls(z)=balls(z)+direction(z)
        draw_balls(balls(z))
        reset_stuff()
    Next z
    Screenunlock
    Sleep Regulate(50,fps)
Loop Until InKey=Chr(27)

FullTime
Imagedestroy im

Sleep

Data _
407, 419, 443, 467, 482, 486, 471, 462, 460, 450, 436, 422, 410, 404, 392, 378, 363, 370, 351, 341, 336, 334, 333, 328, 323, 338, 331, 310, 302, 301, 300, 303, 305, 304, 297, 280, 267, 258, 250, 245, 245, 255, 258, 268, 279, 294, 300, 312, 325, 338, 352, 363, 378, 394


Data _
224, 237, 247, 256, 267, 284, 303, 314, 334, 354, 359, 365, 372, 388, 402, 420, 415, 430, 440, 450, 461, 472, 484, 497, 508, 520, 525, 515, 491, 465, 430, 406, 373, 343, 326, 316, 302, 286, 275, 268, 243, 218, 205, 183, 176, 168, 174, 179, 179, 179, 188, 195, 200, 205


Data _
376, 392, 400, 409, 433, 450, 463, 476, 487, 485, 474, 466, 462, 454, 444, 431, 410, 407, 389, 370, 385, 380, 368, 371, 357, 351, 332, 328, 306, 294, 284, 299, 307, 301, 309, 326, 333, 342, 352, 353, 359


Data _
224, 220, 213, 229, 244, 248, 254, 263, 275, 290, 300, 310, 326, 344, 356, 359, 369, 385, 403, 392, 372, 359, 349, 327, 319, 306, 295, 283, 289, 286, 273, 257, 241, 232, 227, 228, 218, 212, 207, 215, 224