Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
weicher text v3,mit FPS Anzeige, etwas sauberer. bitte testen und bescheidsagen
| Uploader: |  flo |
| Datum/Zeit: | 16.07.2008 18:58:32 |
#macro logge(text)
#ifdef DEBUG
open cons for append as #123:?#123,__FUNCTION__;": ";text:close#123
#endif
#endmacro
#macro xlog(text)
#ifdef XDEBUG
open cons for append as #123:?#123,__FUNCTION__;": ";text:close#123
#endif
#endmacro
#macro uglylog(text)
#ifdef UGLYDEBUG
open cons for append as #123:?#123,__FUNCTION__;": ";text:close#123
#endif
#endmacro
#macro logerror(text)
open cons for append as #123:?#123,__FUNCTION__;": [ERROR] ";text:close#123
#endmacro
#macro logFATAL(text)
open cons for append as #123:?#123,__FUNCTION__;": [FATAL] ";text:close#123
#endmacro
#macro logwarn(text)
open cons for append as #123:?#123,__FUNCTION__;": [WARNING] ";text:close#123
#endmacro
'#include "/home/flo/2.1/inc/log.bi"
#define DEBUG
#define XDEBUG
#define UGLYDEBUG
'#define conswrite(bla) open cons for output as #132: ?#132,bla: close #132
''
'' FreeType2 library test, by jofers (spam[at]betterwebber.com)
'' verändert/umgebaut von flo
#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 GetFont(ByVal FontName As String) As Integer
declare Function PrintTest(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
' 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
' ------------
ScreenRes 320, 240, 32
Dim ArialFont As Integer
ArialFont = GetFont("/usr/local/share/freebasic/examples/libraries/SDL/data/Vera.ttf")
If ArialFont = 0 Then Print "couldn't find it": Sleep: End
dim as integer x,y
For x = 0 to 320
for y = 0 to 239
pset (x, y), x xor y
next y
next x
PrintTest (10,100,"%a08%s+0080%d-0040%y-Fhello world %nist %%das geil",ArialFont,25,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
' ----------
' Print Text
' ----------
Function PrintTest(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
Dim j As Integer
Dim delta as Integer
dim as integer deltax,deltay
Dim add as integer
dim as fb.image ptr zeichen (0 to len(text)-1),zeichenBG(0 to len(text)-1)
dim as integer zx(0 to len(text)-1),zy(0 to len(text)-1)
dim as integer transp(0 to len(text)-1)
zx(0)=x
zy(0)=y
j=0
' 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
logge ("parsing string...")
For i = 0 To Len(Text) - 1
'zx(i)=-1
uglylog ("current position:";i;", character='";chr(Text[i]);"'")
do while Text[i]=asc("%")
uglylog (" found a control-char.")
i=i+1
if i>=len(text) then 'actually if i>len(text)-1
logerror ("there is no function indicator at position";i-2;"! stopping parsing at this point.")
exit for
end if
uglylog (" function indicator='";chr(Text[i]);"'")
if Text[i]=asc("n") then
penX=X:peny+=size+deltay
uglylog (" no parameters.")
i+=1
elseif Text[i]=asc("d") then 'delta
i+=1
if i+4>=len(text) then 'actually if i+4>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
delta=val("&h"+chr(text[i+1])+chr(text[i+2])+chr(text[i+3])+chr(text[i+4]))
if chr(text[i])="-" then delta=-delta
uglylog (" parameters from position ";i;" to ";i+4;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3],text[i+4]))
uglylog (" parsed them as ";delta;".")
i+=5
elseif Text[i]=asc("s") then 'set
i+=1
if i+4>=len(text) then 'actually if i+4>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
transp(j)=val("&h"+chr(text[i+1])+chr(text[i+2])+chr(text[i+3])+chr(text[i+4]))
if chr(text[i])="-" then transp(j)=-transp(j)
uglylog (" parameters from position ";i;" to ";i+4;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3],text[i+4]))
uglylog (" parsed them as ";transp(j);".")
i+=5
elseif Text[i]=asc("a") then 'add-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+4>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
add=val("&h"+chr(text[i],text[i+1]))
uglylog (" parameters from position ";i;" to ";i+1;" are: ";chr(text[i],text[i+1]))
uglylog (" parsed them as ";add;".")
i+=2
elseif Text[i]=asc("x") then 'deltax-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+4>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
deltax=val("&h"+chr(text[i+1]))
if text[i]=asc("-") then deltax=-deltax
uglylog (" parameters from position ";i;" to ";i+1;" are: ";chr(text[i],text[i+1]))
uglylog (" parsed them as ";add;".")
i+=2
elseif Text[i]=asc("y") then 'deltay-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+4>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
deltay=val("&h"+chr(text[i+1]))
if text[i]=asc("-") then deltay=-deltay
uglylog (" parameters from position ";i;" to ";i+1;" are: ";chr(text[i],text[i+1]))
uglylog (" parsed them as ";add;".")
i+=2
else
uglylog (" no parameters, parsed as '";chr(text[i]);"'")
exit do
end if
if i>=len(text) then exit for
uglylog ("current position:";i;", character='";chr(Text[i]);"'")
loop
transp(j+1)=transp(j)+delta
' 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 PenX=X:PenY+=size+deltay'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
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
if BitmapWid>0 and BitmapHgt>0 then
zeichen(j)=imagecreate(BitmapWid,BitmapHgt)
zeichenBG(j)=imagecreate(BitmapWid,BitmapHgt)
zx(j)=PenX + FontFT->Glyph->Bitmap_Left
zy(j)=PenY - FontFT->Glyph->Bitmap_Top
BitmapPitch=(zeichen(j)->pitch)\4-BitmapWid
'conswrite (BitmapPitch;" , ";zeichen(j)->pitch)
'sleep
get (zx(j),zy(j))-step (BitmapWid-1,BitmapHgt-1),zeichen(j)
get (zx(j),zy(j))-step (BitmapWid-1,BitmapHgt-1),zeichenBG(j)
DestPtr = Cast(UInteger Ptr, zeichen(j)+1)
'DestPtr+=8 '(sizeof(fb.image)\sizeof(uinteger))
'put (1,1),zeichen(i),pset
'sleep
'*(DestPtr+BitmapWid*BitmapHgt)=rgb (127,127,127)
'put (1,1),zeichen(i),pset
'sleep
'sleep
Do While BitmapHgt
Do While BitmapWid
'conswrite (BitmapWid;" ";BitmapHgt)
' 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=rgb(255,255,255)
DestPtr += 1
BitmapPtr += 1
BitmapWid -= 1
Loop
BitmapWid = BitmapFT.Width
BitmapHgt -= 1
DestPtr+=BitmapPitch
Loop
'put (zx(i),zy(i)),zeichen(i),pset
'sleep
else
zeichen(j)=imagecreate (0,0)
zeichenBG(j)=imagecreate(0,0)
end if
'DrawGlyph FontFT, PenX + FontFT->Glyph->Bitmap_Left, PenY - FontFT->Glyph->Bitmap_Top, Clr
PenX +=(Slot->Advance.x Shr 6 )+deltax
j+=1
Next i
logge ("done.")
dim as double start,s2
dim as integer fpscount
do
start=timer
fpscount+=1
if timer-s2>=0.25 then
logge (fpscount*4;" FPS")
fpscount=0:s2=timer
end if
for i=0 to j-1
transp(i)+=add
if transp (i)>0 and transp(i)<255 then
put (zx(i),zy(i)),ZeichenBG(i),pset
put (zx(i),zy(i)),Zeichen(i),alpha,transp(i)
end if
next
do : loop until timer-start>=0.01
loop until transp(j-1)>=255
End Function