Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Draw String with UTF-8 characters
| Uploader: |  RockTheSchock |
| Datum/Zeit: | 10.12.2014 10:07:07 |
#Include "freetype2/freetype.bi"
#DEFINE ENDE(_P_) ?_P_ : Sleep : End ' on init errors
#define UTF8_ACCEPT 0
#define UTF8_REJECT 12
' Initial setup
Dim As Integer screen_w = 1024
Dim As Integer screen_h = 768
'ScreenInfo screen_w, screen_h
ScreenRes screen_w, screen_h, 32
' Constants
Const font_filename = "C:\WINDOWS\FONTS\ARIALUNI.ttf"
'Const font_filename = "C:\WINDOWS\Fonts\arial.ttf"
'Const font_filename = "Cardo104s.ttf"
Const font_size = 18
'' Original program:
'' FreeType2 library test, by jofers (spam[at]betterwebber.com)
''
'Ich (flo) hab "nur" das weiche einblenden dazugefügt, (dafür musste ich nen neuen parameter zur DrawGlyph-SUB hinzufügen (myalpha))
'außerdem macht er ne neue zeile wenn \n im string erscheint wird.
#Include "fbgfx.bi"
#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 Function decode(ByRef state As ULong,ByRef codep As ULong,ByVal b As ULong) As ULong
Declare Sub DrawGlyph(ByVal FontFT As FT_Face, ByVal x As Integer, ByVal y As Integer, ByVal Clr As UInteger,myalpha As UByte)
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), ByVal tr As UByte=255) As Integer
Declare Function GetFont(ByVal FontName As String) As Integer
' Initialize FreeType
' -------------------
FT_Var.ErrorMsg = FT_Init_FreeType(@FT_Var.Library)
If FT_Var.ErrorMsg Then
Print "Could not load library"
End
End If
' Your program
' ------------
Dim text As String
ScreenRes 800, 240, 32
Dim ArialFont As Integer
ArialFont = GetFont(font_filename)
If ArialFont = 0 Then Print "couldn't find it": Sleep: End
text=!"schau mal, \&hE2\&h82\&hAC diese toooooooooolle textausgabe\nschaut doch gut aus. \noder?"
PrintFT 10,100,text,arialfont,23,RGB(255,255,0)
Sleep
' 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), ByVal tr As UByte=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
Dim temph As Integer
Dim As ULong codepoint
Dim As ULong state = 0
Const As Integer plus=5
' 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
Slot = FontFT->Glyph
PenX = x
PenY = y
ScreenLock
For i = 0 To Len(Text) - 1
If decode(state, codepoint, text[i])=0 Then
If codepoint = 10 Then 'newline character
penx=x:peny+=size+plus
Continue For
End If
' Load character index
GlyphIndex = FT_Get_Char_Index(FontFT, codepoint)
' 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) > 800 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
DrawGlyph FontFT, PenX + FontFT->Glyph->Bitmap_Left, PenY - FontFT->Glyph->Bitmap_Top, Clr,tr
PenX += Slot->Advance.x Shr 6
End If
Next i
ScreenUnLock
End Function
Sub DrawGlyph(ByVal FontFT As FT_Face, ByVal x As Integer, ByVal y As Integer, ByVal Clr As UInteger,myalpha As UByte)
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 = 800 - BitmapFT.Width
DestPtr = Cast(UInteger Ptr, ScreenPtr) + (y * 800) + 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
Alpha=Alpha*(myalpha/255)
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
'-----------------------------------------------------------------------------------
'License
'Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
'Tranlsated To FreeBasic by Rocco Lavella
'Permission is hereby granted, free of charge, to any person obtaining a
'copy of this software and associated documentation files (the "Software"),
'to deal in the Software without restriction, including without limitation
'the rights to use, copy, modify, merge, publish, distribute, sublicense,
'and/or sell copies of the Software, and to permit persons to whom the Software
'is furnished to do so, subject to the following conditions:
'The above copyright notice and this permission notice shall be included in
'all copies or substantial portions of the Software.
'THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
'INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR
'A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
'*COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
'WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
'OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
'
Dim Shared As UByte utf8d(399) = {_
_ 'The first part of the table maps bytes to character classes that
_ 'to reduce the size of the transition table and create bitmasks.
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,_
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,_
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,_
10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,_
_ 'The second part is a transition table that maps a combination
_ 'of a state of the automaton and a character class to a state.
0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,_
12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,_
12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,_
12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,_
12,36,12,12,12,12,12,12,12,12,12,12 }
' Decode unicode characters
' -------------------------
Function decode(ByRef state As ULong,ByRef codep As ULong,ByVal b As ULong) As ULong
Dim As ULong t = utf8d(b)
If (state <> UTF8_ACCEPT) Then
codep = (b And &h3fu) Or (codep Shl 6)
Else
codep = (&hff Shr t) And b
EndIf
state = utf8d(256 + state + t)
Return state
End Function