FreeBasic

Очень хороший пример , создающий эффект 3D у строки.

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

Sub draw_string(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle As Single=0)
    Type point2d
        As Single x,y
        As Uinteger col
    End Type
    Dim As Integer codenum=128            '(Full Asci 256 if required)
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=RGB(0,0,0)
        Screenres 10,10,32  '8 x 8 pixels on this screen
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 8
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If
                Next y
            Next x
            count=0
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 64,codenum),np
    Dim As Single cr= 0.01745329,x1,y1,x2,y2
    #MACRO rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #EndMacro
    #MACRO box()
    Dim As Single dx=x2-x1,dy=y2-y1
    Swap dx,dy:dx=-dx
    Dim As Single p1x=x1+dx/2,p1y=y1+dy/2
    Dim As Single p2x=x1-dx/2,p2y=y1-dy/2
    Dim As Single p3x=x2+dx/2,p3y=y2+dy/2
    Dim As Single p4x=x2-dx/2,p4y=y2-dy/2
    Dim As Uinteger c=RGB(255,255,254)
    For x As Integer=1 To 2
        Line(p1x,p1y)-(p2x,p2y),c
        Line(p3x,p3y)-(p4x,p4y),c
        Line(p1x,p1y)-(p3x,p3y),c
        Line(p2x,p2y)-(p4x,p4y),c
        Paint((p1x+p2x+p3x+p4x)/4,(p1y+p2y+p3y+p4y)/4),c,c
        c=cpt(z).col
    Next x
    #EndMacro
    Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
    Dim As Single sz =size/2
    Dim As Integer dx=xpos,dy=ypos,asci
    For z6 As Integer=1 To Len(text)
        asci=Asc(Mid(text,z6,1))
        For x1 As Integer=1 To 64
            temp(x1,asci).x=infoarray(x1,asci).x+dx
            temp(x1,asci).y=infoarray(x1,asci).y+dy
            temp(x1,asci).col=colour
        Next x1
        c2=Type<point2d>(xpos+(size*(z6-1)*8)*Cos(textangle*cr),ypos+(size*(z6-1)*8)*Sin(textangle*cr))
        For z2 As Integer=1 To 64
            rotate(c,temp(z2,asci),textangle,size)
            cpt(z2)=np
            If charangle<>0 Then
                rotate(c2,cpt(z2),charangle,1)
                cpt(z2)=np
            End If
        Next z2
        For z As Integer=1 To 64
            x1=cpt(z).x-sz*(Cos((textangle+charangle)*cr)):y1=cpt(z).y-sz*(Sin((textangle+CHARANGLE)*cr))
            x2=cpt(z).x+sz*(Cos((textangle+charangle)*cr)):y2=cpt(z).y+sz*(Sin((textangle+charangle)*cr))
            If infoarray(z,asci).x<>0 Then 'paint only relevant points
                If Abs(size)>1 Then
                    box()
                Else
                    Pset(cpt(z).x,cpt(z).y),cpt(z).col
                End If
            End If
        Next z
        dx=dx+8
    Next z6
End Sub
Function background As Any Pointer
    Dim As Integer xres,yres
    Screeninfo xres,yres
    Dim As Any Pointer im
    im=ImageCreate(xres,yres)
    #DEFINE rads *(100*Atn(1))/180
    Dim As Integer x,y,z
    For x=0 To xres
        For y=0 To yres
            z=31*(Sin(.1*y rads)*Cos(.1*x rads))^.1
            Pset im,(x,y),z
        Next y
    Next x
    Return im
End Function

draw_string(0,0,"",0,0) 'must initialize before setting screen by this line

Screen 19
Dim As Any Pointer im=background

Do

    Screenlock
    Put(0,0),im,Pset
    For x As Integer=20 To 31
        draw_string(100+x,150-x,Time,x,10,25,-25)
    Next x
    Screenunlock
    Sleep 1,1
Loop Until InKey=Chr(27)