FreeBasic

Великолепный пример , реализующий анимацию смайликов (автор их назвал свингерами) в 3D пространстве с тенями и различными степенями прозрачности. Кроме того реализована физика столкновений. В примере активно используются макросы и перегрузка операторов. Вся графика выполнена средствами встроенной библиотеки FBGFX.

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

Screen 20,32,,64
Dim Shared As Integer xres,yres
Screeninfo xres,yres
Dim Shared As Any Pointer im

Type vector
    As Single x,y,z
    #DEFINE vct Type<vector>
    #DEFINE dot *
    #DEFINE cross ^
End Type

Type plane
    As vector v1,v2,v3
End Type
Type _object
    As vector position,velocity
    As Single mass,radius
End Type

Operator + (v1 As vector,v2 As vector) As vector
    Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As vector,v2 As vector) As vector
    Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As vector) As vector 'scalar*vector
    Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (v1 As vector,v2 As vector) As Single 'dot product
    Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (v1 As vector,v2 As vector) As vector 'cross product
    Return vct(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
'subs
Function length(v As vector) As Single
    Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function

Function normalize(v As vector) As vector
    Dim n As Single=length(v)
    If n=0 Then n=1e-20
    Return vct(v.x/n,v.y/n,v.z/n)
End Function
Function rotate3d(Byval pivot As vector,Byval pt As vector,Byval Angle As vector, Byval scale As vector=vct(1,1,1)) As vector
    #DEFINE cr 0.0174532925199433
    Angle=vct(Angle.x*cr,Angle.y*cr,Angle.z*cr)
    #MACRO Rotate(a1,a2,b1,b2,d)
        temp=vct((a1)*Cos(Angle.d)+(a2)*Sin(Angle.d),(b1)*Cos(Angle.d)+(b2)*Sin(Angle.d))
    #endmacro
    Dim As vector p=vct(pt.x-pivot.x,pt.y-pivot.y,pt.z-pivot.z)
    Dim As vector rot,temp
    Rotate(p.y,-p.z,p.z,p.y,x)'X
    rot.y=temp.x:rot.z=temp.y
    p.y = rot.y:p.z = rot.z
    Rotate(p.z,-p.x,p.x,p.z,y)'Y
    rot.z=temp.x:rot.x=temp.y
    p.x=rot.x
    Rotate(p.x,-p.y,p.y,p.x,z)'Z
    rot.x=temp.x:rot.y=temp.y
    Return vct((scale.x*rot.x+pivot.x),(scale.y*rot.y+pivot.y),(scale.z*rot.z+pivot.z))
End Function
Function apply_perspective(p As vector,eyepoint As vector) As vector
    Dim As Single   w=1-(p.z/eyepoint.z)
    If w=0 Then w=1e-20
    Return vct((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z)
End Function
Sub blow(a() As vector,m As Double)
    For z As Integer=1 To Ubound(a)
        a(z)=m*a(z)
    Next z
End Sub
Sub translate(a() As vector,shift As vector)
    For z As Integer=1 To Ubound(a)
        a(z)=a(z)+shift
    Next z
End Sub

Sub drawpolygon(p() As vector,i As Integer,col As Uinteger,flag As String="",im As Any Pointer=0)
    Dim k As Integer=Ubound(p,1)+1
    Dim As Integer index,nextindex
    Dim As Double xc,yc
    For n As Integer=1 To Ubound(p,1)
        xc=xc+p(n,i).x:yc=yc+p(n,i).y
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        Line im,(p(index,i).x,p(index,i).y)-(p(nextindex,i).x,p(nextindex,i).y),col
    Next
    xc=xc/Ubound(p,1):yc=yc/Ubound(p,1)
    If flag="fill" Then Paint (xc,yc),col,col
End Sub
Function planedistance(S As PLANE,p As vector,Byref ip As vector=vct(0,0,0)) As Single
    Dim As vector unitcross=normalize((s.v1-s.v2) cross (S.v2-S.v3))
    Dim As Single dist=unitcross dot (p-s.v1)'pv
    Dim As vector ip1=p+dist*unitcross
    Dim As Single d1=length(s.v1-ip1)
    unitcross=-1*unitcross
    Dim As vector ip2=p+dist*unitcross
    Dim As Single d2=length(s.v1-ip2)
    If d1 <= d2 Then ip=ip1 Else ip=ip2
    Return dist
End Function
Sub PAINTBALL(cx As Double,_
    cy As Double,_
    radius As Double,_
    col() As Uinteger,_
    offsetX As Double=0,_
    offsetY As Double=0,_
    e As Double=0,_
    resolution As Double=32,_
    im As Any Pointer=0)
    Dim As Integer red,green,blue,r,g,b
    Static As Single alp,k
    alp=alp+.05*k
    If alp<=0 Then k=1
    If alp>=255 Then k=-1
    Dim As Double ox,oy,nx,ny,pi=4*atn(1)
    ox=cx+offsetX*radius
    oy=cy+offsetY*radius
    red=col(1): green=col(2):blue=col(3)
    For d As Double = radius To 0 Step -radius/resolution
        nx=(cx-ox)*(d-radius)/radius + cx
        ny=(cy-oy)*(d-radius)/radius + cy
        r=-red*(d/radius-1)
        g=-green*(d/radius-1)
        b=-blue*(d/radius-1)
        Circle im,(nx,ny),d,Rgba(r,g,b,alp),,,e,F
    Next d
    Circle(cx-.3*radius,cy-.3*radius),.2*radius,Rgb(0,0,0),,,,f
    Circle(cx+.3*radius,cy-.3*radius),.2*radius,Rgb(0,0,0),,,,f
    Circle(cx-.3*radius*(1+.3*sin(alp*pi/180)),cy-.3*radius),.05*radius,Rgb(255,255,255),,,,f
    Circle(cx+.3*radius*(1-.3*sin(alp*pi/180)),cy-.3*radius),.05*radius,Rgb(255,255,255),,,,f
    For z As single=1 To .1*radius
        Circle(cx,cy),.55*radius+z,Rgba(0,0,0,alp),pi+.3*pi,pi+.7*pi
        Circle(cx,cy+radius),.55*radius+z,Rgba(0,0,0,255-alp),1,pi-1
    Next z
End Sub

Function vradius(b As _object) As Single
    Dim As Single d=xres/5
    Return ((1.5-.8)*(b.position.z+d)/(2*d)+.8)*b.radius
End Function

'variables
Dim As vector e(1 To 24),ve(1 To 24),pivot=vct(xres/2,yres/2,0)
Dim As vector angle,scale=vct(1,1,1),temp
Dim As Uinteger fcolour(1 To 10)
Dim As plane side(1 To 6)
Dim As vector face(1 To 4,6)
Dim As Single t,pi=4*Atn(1)
Dim  As vector impulse,impact,closepoint
Dim As Integer col(1 To 3)
Redim   As Single _dt(0,0) 'register of impact dot impulse
Dim As Single ma,mb,seperation
Redim As _object ball()
Dim As Integer count
Redim As vector ballcol()
'macros
#MACRO start()
    #DEFINE rr(f,l) (Rnd*(l-f)+f)
For z As Integer=1 To 10:fcolour(z)=Rgb(Rnd*200,Rnd*200,Rnd*200):Next z'floorboards
e(1) =vct( 1, 1,-1)
e(2) =vct(-1, 1,-1)
e(3) =vct(-1, 1, 1)
e(4) =vct( 1, 1, 1)
side(1)=Type<plane>(e(1),e(2),e(3))

e(5) =vct( 1,-1, 1)
e(6) =vct(-1,-1, 1)
e(7) =vct(-1,-1,-1)
e(8) =vct( 1,-1,-1)
side(2)=Type<plane>(e(5),e(6),e(7))

e(9) =vct( 1, 1, 1)
e(10)=vct(-1, 1, 1)
e(11)=vct(-1,-1, 1)
e(12)=vct( 1,-1, 1)
side(3)=Type<plane>(e(9),e(10),e(11))

e(13)=vct( 1,-1,-1)
e(14)=vct(-1,-1,-1)
e(15)=vct(-1, 1,-1)
e(16)=vct( 1, 1,-1)
side(4)=Type<plane>(e(13),e(14),e(15))

e(17)=vct(-1, 1, 1)
e(18)=vct(-1, 1,-1)
e(19)=vct(-1,-1,-1)
e(20)=vct(-1,-1, 1)
side(5)=Type<plane>(e(17),e(18),e(19))

e(21)=vct( 1, 1,-1)
e(22)=vct( 1, 1, 1)
e(23)=vct( 1,-1, 1)
e(24)=vct( 1,-1,-1)
side(6)=Type<plane>(e(21),e(22),e(23))

blow(e(),xres/5)            'magnify
translate(e(),vct(xres/2,yres/2,0)) 'centralize
side(1)=Type<plane>(e(1),e(2),e(3))
side(2)=Type<plane>(e(5),e(6),e(7))
side(3)=Type<plane>(e(9),e(10),e(11))
side(4)=Type<plane>(e(13),e(14),e(15))
side(5)=Type<plane>(e(17),e(18),e(19))
side(6)=Type<plane>(e(21),e(22),e(23))

For x As Integer=.3*xres To .7*xres Step xres/10
    For y As Integer=.3*yres To .7*yres Step yres/10
        For z As Integer=1 To Ubound(side)'-1
            If Abs(planedistance(side(z),vct(x,y,z*20)))<30 Then   Goto skip
        Next z
        count=count+1
        Redim Preserve ball(count)
        ball(count).position=vct(x,y,0)
        ball(count).radius=25
        ball(count).mass=4.18*ball(count).radius^3
        ball(count).velocity=vct(rr(-1,1),rr(-1,1),rr(1,5))
        ball(count).velocity=1.5*normalize((ball(count).velocity))
        skip:
    Next y
Next x
Redim _dt(1 To count,1 To count)
Redim ballcol(count)
For z As Integer=1 To Ubound(ballcol)
    ballcol(z)=vct(Rnd*200,Rnd*155,Rnd*255)
Next z
#endmacro

#MACRO rotatebox()
    For a As Integer=1 To Ubound(e)
        temp=rotate3d(pivot,e(a),angle,scale)
        ve(a)=apply_perspective(temp,vct(xres/2,yres/2,500))
    Next a
#endmacro

#MACRO setfaces()
    Scope
        Dim As Integer s,c
        Do
            c=c+1
For n As Integer=1 To 4: face(n,c)=ve(n+s):Next n
s=s+4
        Loop Until c=7-1
    End Scope
#endmacro

#MACRO drawfaces()
    Scope
        Dim As Uinteger col
        For a As Integer=1 To Ubound(face,2)
            Select Case As Const a
                Case 2:col=Rgb(200,240,255)
                Case 4:col=Rgb(50,50,100)
                Case 5,6:col=Rgb(100,100,150)
            End Select
            If a<>3 And a<>1 Then drawpolygon(face(),a,col,"fill")
        Next a

        Dim As vector back,front
        Dim As vector pts(1 To 2)
        Dim As Integer count
        back=face(2,1)-face(1,1)
        front=face(3,1)-face(4,1)
        drawpolygon(face(),1,Rgb(100,100,150))
        For a As Single=0 To 1 Step .1
            count=count+1
            pts(1)=face(1,1)+a*back
            pts(2)=face(4,1)+a*front
            Line(pts(1).x,pts(1).y)-(pts(2).x,pts(2).y),Rgb(100,100,150)
            Paint(.5*(pts(2).x+pts(1).x)-25,2+.5*(pts(2).y+pts(1).y)),fcolour(count),Rgb(100,100,150)
        Next a
        drawpolygon(face(),3,Rgb(200,0,0))
    End Scope
#endmacro

#MACRO zsort(n)
    For p1 As Integer = 1 To n - 1
        For p2 As Integer  = p1 + 1 To n
            If vradius(ball(p1))>vradius(ball(p2)) Then
                Swap ball(p1),ball(p2):Swap ballcol(p1),ballcol(p2)
            End If
        Next p2
    Next p1
#endmacro

#MACRO check_ball_to_plane_collisions()
    Scope
        Dim As vector temp
        Dim As Single s
        s=.5-(angle.x)/60
        For z As Integer=1 To Ubound(ball)
            For z2 As Integer=1 To Ubound(side)
                seperation=Abs(planedistance(side(z2),ball(z).position,closepoint))
                temp=closepoint
                temp=rotate3d(pivot,temp,angle,scale)
                temp=apply_perspective(temp,vct(xres/2,yres/2,500))
                If z2=1 Then Circle(temp.x,temp.y),vradius(ball(z)),Rgba(0,0,0,50),,,s,f
                If seperation>ball(z).radius Then _dt(z,z)=0
                If seperation<=ball(z).radius Then
                    If _dt(z,z)=0 Then
                        impact=-1*ball(z).velocity
                        impulse=normalize(closepoint-ball(z).position)
                        _dt(z,z)=(impact dot impulse)
                        ball(z).velocity=ball(z).velocity +2*_dt(z,z)*impulse
                    End If
                End If
            Next z2
        Next z
    End Scope
#endmacro
#MACRO check_ball_to_ball_collisions()
    For x As Integer=1 To Ubound(ball)-1
        For y As Integer=x+1 To Ubound(ball)
            seperation=length((ball(x).position-ball(y).position))
            If seperation>(ball(x).radius+ball(y).radius) Then _dt(x,y)=0
            If seperation<=ball(x).radius+ball(y).radius Then
                If _dt(x,y)=0 Then
                    impulse=normalize((ball(x).position-ball(y).position))
                    impact=ball(x).velocity-ball(y).velocity
                    _dt(x,y)=(impact dot impulse)
                    ma=ball(x).mass:mb=ball(y).mass
                    ball(x).velocity=ball(x).velocity-_dt(x,y)*((2*mb/(ma+mb)))*impulse
                    ball(y).velocity=ball(y).velocity+_dt(x,y)*((2*ma/(mb+ma)))*impulse
                End If
            End If
        Next y
    Next x
#endmacro

#MACRO drawballs()
    Scope
        Dim As vector temp
        For z As Integer=1 To Ubound(ball)
            col(1)=ballcol(z).x:col(2)=ballcol(z).y:col(3)=ballcol(z).z
            ball(z).position=ball(z).position+ball(z).velocity
            temp=rotate3d(pivot,ball(z).position,angle,scale)
            temp=apply_perspective(temp,vct(xres/2,yres/2,500))
            paintball(temp.x,temp.y,vradius(ball(z)),col(),0,-.8)
        Next z
    End Scope
#endmacro
'===================================================
start()
Do
    t=t+.1:If t>=360 Then t=0
    angle.z=10*cos(2*t*pi/180)'roll
    angle.x=20*Cos(3*t*pi/180)'yaw
    angle.y=15*Cos(2*t*pi/180)'pitch

    rotatebox()
    setfaces()
    Screenlock
    Cls
    drawfaces()
    check_ball_to_ball_collisions()
    check_ball_to_plane_collisions()
    zsort(Ubound(ball))
    drawballs()
    Screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)

Sleep