fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Freetype...

Uploader:	max06
Datum/Zeit:	23.03.2008 15:01:57
#include "freetype2/freetype.bi"



' Alpha blending

#define FT_MASK_RB_32         &h00FF00FF

#define FT_MASK_G_32         &h0000FF00



' DataStructure to make it easy

Type FT_Var

    ErrorMsg   As FT_Error

    Library    As FT_Library

    PixelSize  As Integer

End Type



Dim Shared FT_Var As FT_Var



Declare sub DrawGlyph(ByVal FontFT As FT_Face, ByVal x As Integer, ByVal y As Integer, ByVal Clr As UInteger)

Declare Function PrintFT(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal Font As Integer, ByVal Size As Integer = 14, ByVal Clr As UInteger = Rgb(255, 255, 255)) as integer

Declare Function GetFont(ByVal FontName As String) As Integer



DIM Shared AS  INTEGER Timer1, FPS,FCount                   'Definitionen der Variablen

timer1=TIMER+1                                      'Start-TIMER festlegen



Sub FPS_Calc ()

    FCount +=1                                  'Frames zählen

    IF TIMER >= timer1 THEN                      'Wenn 1 Sekunde vergangen ist

       FPS=Fcount                               'werden die Zählvorgänge gespeichert

       FCount=0                                 'der Zähler zurückgesetzt

       Timer1=TIMER+1                           'und der TIMER neu gesetzt

    EndIf

    print "FPS :";FPS

End Sub





Dim As Byte Ptr splashimage1





ScreenRes 480, 272, 32, 2, &H10



    ' Initialize FreeType

    ' -------------------

    FT_Var.ErrorMsg = FT_Init_FreeType(@FT_Var.Library)

    If FT_Var.ErrorMsg Then

        Print "Could not load library"

        End

    End If



        Dim ArialFont As Integer

    ArialFont = GetFont("Inc/Vera.ttf")

    If ArialFont = 0 Then Print "couldn't find it": Sleep: End





splashimage1=ImageCreate(480, 272)

BLoad("Inc\splash1.bmp", splashimage1)



Color(RGB(0,0,0),RGB(255,255,255))



Do while InKey<>Chr(27)

    ScreenLock

        Cls

        Put (0,0), splashimage1, PSet

        Print "Hallo"

        PrintFT (0, 120, "Hello World!", ArialFont, 22, RGB(0,0,0))

        FPS_Calc()

    ScreenUnLock

    Sleep 1

Loop





' Load a font

' -----------

Function GetFont(ByVal FontName As String) As Integer

    Dim Face As FT_Face

    Dim ErrorMsg As FT_Error



    ErrorMsg = FT_New_Face(FT_Var.Library, FontName, 0, @Face )

   If ErrorMsg Then Return 0



    Return CInt(Face)

End Function



' Print Text

' ----------

Function PrintFT(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal Font As Integer, ByVal Size As Integer = 14, ByVal Clr As UInteger = Rgb(255, 255, 255)) as integer

    Dim ErrorMsg   As FT_Error

    Dim FontFT     As FT_Face

    Dim GlyphIndex As FT_UInt

    Dim Slot       As FT_GlyphSlot

    Dim PenX       As Integer

    Dim PenY       As Integer

    Dim i          As Integer



    ' Get rid of any alpha channel in AlphaClr

    Clr = Clr Shl 8 Shr 8



    ' Convert font handle

    FontFT = Cast(FT_Face, Font)



    ' Set font size

    ErrorMsg = FT_Set_Pixel_Sizes(FontFT, Size, Size)

    FT_Var.PixelSize = Size

   If ErrorMsg Then Return 0



    ' Draw each character

    Slot = FontFT->Glyph

    PenX = x

    PenY = y



    For i = 0 To Len(Text) - 1

        ' Load character index

        GlyphIndex = FT_Get_Char_Index(FontFT, Text[i])



        ' Load character glyph

        ErrorMsg = FT_Load_Glyph(FontFT, GlyphIndex, FT_LOAD_DEFAULT)

        If ErrorMsg Then Return 0



        ' Render glyph

        ErrorMsg = FT_Render_Glyph(FontFT->Glyph, FT_RENDER_MODE_NORMAL)

        If ErrorMsg Then Return 0



        ' Check clipping

        If (PenX + FontFT->Glyph->Bitmap_Left + FontFT->Glyph->Bitmap.Width) > 320 Then Exit For

        If (PenY - FontFT->Glyph->Bitmap_Top + FontFT->Glyph->Bitmap.Rows) > 240 Then Exit For

        If (PenX + FontFT->Glyph->Bitmap_Left) < 0 Then Exit For

        If (PenY - FontFT->Glyph->Bitmap_Top) < 0 Then Exit For



        ' Set pixels

        DrawGlyph FontFT, PenX + FontFT->Glyph->Bitmap_Left, PenY - FontFT->Glyph->Bitmap_Top, Clr



        PenX += Slot->Advance.x Shr 6

    Next i

End Function



sub DrawGlyph(ByVal FontFT As FT_Face, ByVal x As Integer, ByVal y As Integer, ByVal Clr As UInteger)

    Dim BitmapFT As FT_Bitmap

    Dim BitmapPtr As UByte Ptr

    Dim DestPtr As UInteger Ptr



    Dim BitmapHgt As Integer

    Dim BitmapWid As Integer

    Dim BitmapPitch As Integer



    Dim Src_RB As UInteger

    Dim Src_G As UInteger

    Dim Dst_RB As UInteger

    Dim Dst_G As UInteger

    Dim Dst_Color As UInteger

    Dim Alpha As Integer



    BitmapFT = FontFT->Glyph->Bitmap

    BitmapPtr = BitmapFT.Buffer

    BitmapWid = BitmapFT.Width

    BitmapHgt = BitmapFT.Rows

    BitmapPitch = 320 - BitmapFT.Width



    DestPtr = Cast(UInteger Ptr, ScreenPtr) + (y * 320) + x



    Do While BitmapHgt

        Do While BitmapWid

            ' Thanks, GfxLib

            Src_RB = Clr And FT_MASK_RB_32

            Src_G  = Clr And FT_MASK_G_32



            Dst_Color = *DestPtr

            Alpha = *BitmapPtr



            Dst_RB = Dst_Color And FT_MASK_RB_32

            Dst_G  = Dst_Color And FT_MASK_G_32



            Src_RB = ((Src_RB - Dst_RB) * Alpha) Shr 8

            Src_G  = ((Src_G - Dst_G) * Alpha) Shr 8



            *DestPtr = ((Dst_RB + Src_RB) And FT_MASK_RB_32) Or ((Dst_G + Src_G) And FT_MASK_G_32)



            DestPtr += 1

            BitmapPtr += 1

            BitmapWid -= 1

        Loop



        BitmapWid = BitmapFT.Width

        BitmapHgt -= 1

        DestPtr += BitmapPitch

    Loop



End Sub