Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
FadeText! (aka text weich einblenden via Freetype)
| Uploader: |  flo |
| Datum/Zeit: | 08.01.2009 18:28:33 |
' routines for rendering text are from FreeType2 library test, by jofers (spam[at]betterwebber.com)
' THANK YOU jofers :) !!!!!!!!!!!!!!!!!1111oneoneeleven
' Copyright 2009 Florian Jung <florian.a.jung@gmx.de>
'
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
' MA 02110-1301, USA.
'Unfortunately, i wasn't able to find any licensing hint in jofers original code.
'so, jofers, when you don't want your code used like that, please tell me.
'This is not even a beta-version! Don't expect everything to work, but when you find an error, please tell me!
#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
#ifdef WAITONERROR
sleep
#endif
#endmacro
#macro logFATAL(text)
open cons for append as #123:?#123,__FUNCTION__;": [FATAL] ";text:close#123
#ifdef WAITONERROR
sleep
#endif
#endmacro
#macro logwarn(text)
open cons for append as #123:?#123,__FUNCTION__;": [WARNING] ";text:close#123
#ifdef WAITONWARNING
sleep
#endif
#endmacro
#define false 0
#define true (not false)
#define debug
#include once "fbgfx.bi"
#include once "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
type FT_Select
x as integer
y as integer
end type
declare sub FTSleep (inptr() as any ptr, outptr() as any ptr)
declare sub FadeText_Select (inptr () as any ptr, outptr () as any ptr)
declare Function FT_Pos(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal Font As Integer, ByVal Size As Integer = 14,retval() as integer,FT_Var as FT_Var) as integer
Declare Function GetFont(ByVal FontName As String,FT_Var as FT_Var) As Integer
declare Function FadeText overload (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), func as sub (inptr() as any ptr, outptr() as any ptr), inptr() as any ptr, outptr() as any ptr,FT_Var as FT_Var) as integer'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
declare Function FadeText(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),FT_Var as FT_Var) as integer
declare Function FadeInput(ByVal x As Integer, ByVal y As Integer, maxlen as integer, ByVal Font As Integer, ByVal Size As Integer = 14, ByVal Clr As UInteger = Rgb(255, 255, 255),FT_Var as FT_Var) as string
Dim Shared FT_Var As FT_Var
' Initialize FreeType
FT_Var.ErrorMsg = FT_Init_FreeType(@FT_Var.Library)
If FT_Var.ErrorMsg Then
logfatal ("couldn't load FreeType!")
End
End If
'Load font
Dim shared GameFont As Integer
dim shared font_to_load as string
line input "please enter the path to a ttf file: ",font_to_load
GameFont = GetFont(font_to_load,FT_Var)
If GameFont = 0 Then
logFATAL("Couldn't load font!")
End
end if
screenres 800,600,32
fadetext (100,100,"FadeText demo",gamefont,64,rgb(255,255,255),FT_Var)
fadetext (100,100,"by Florian Jung%n(florian.a.jung@gmx.de)%c232",gamefont,64,rgb(255,255,255),FT_Var)
sleep 3000
fadetext (100,100,"you saw how you can output 'normal' text, without any interaction.%nbut FadeText is also able to wait for the user, or to execute SUBs!",gamefont,20,rgb(255,255,0),FT_Var)
dim as integer coordinates(0 to 5)
dim as any ptr inptr (0 to 4)
dim as integer i
dim as integer nChoices,Choice
Choice=1
nChoices=3
inptr(0)=cast(any ptr,@nChoices)
dim as any ptr outptr(0 to 0)
dim as FT_Select selecttemp(0 to 2)
FT_Pos (100,100,"for example, you can choose between three items: item one %p %p item two %n %p or item three",gamefont,20,coordinates(),FT_Var)
for i=0 to 2
selecttemp(i).x=coordinates(i*2)
selecttemp(i).y=coordinates(i*2+1)-20*0.3 -5
logge (selecttemp(i).x;",";selecttemp(i).y)
inptr(i+1)=cast(any ptr,@selecttemp(i))
next
inptr(4)=cast(any ptr,@Choice)
outptr(0)=cast(any ptr,@Choice)
fadetext (100,100,"for example, you can choose between three items: item one item two %n or item three %n(try up,down,enter/space) ",gamefont,20,rgb(255,0,0),@FadeText_Select,inptr(),outptr(),FT_Var)
fadetext (100,100,"i admit: the current syntax sucks, but i'll%nprovide a way to do that easier soon (hopefully :p)",gamefont,20,rgb(0,0,255),FT_Var)
dim as integer sleeptime,keypress
sleeptime=5000 'in msec, aborting by keypress is allowed. (-5000 would forbid aborting by keypress)
inptr(0)=cast(any ptr,@sleeptime)
outptr(0)=cast(any ptr,@keypress)
fadetext (100,100,"now we'll wait 5 sec that you can read the text.%nwith hitting any key you can abort this.",gamefont,20,rgb(255,0,0),@FTSleep,inptr(),outptr(),FT_Var)
fadetext(100,100,"here i'll try to provide a more comfortable way, too",gamefont,20,rgb(0,0,255),FT_Var)
fadetext (100,100,"now please enter your name (or any other text...)",gamefont,24,rgb(127,127,127),FT_Var)
do : loop while inkey<>"" 'empty keybuffer
dim as string tmp
tmp=fadeinput (100,100,50,gamefont,20,rgb(255,255,255),FT_Var)
fadetext (100,100,"you entered:%n"+tmp,gamefont,22,rgb(255,255,0),FT_Var)
sleep 1000
fadetext (100,100,"CIAO!%c102",gamefont,32,rgb(255,255,255),FT_Var)
end
' Load a font
' -----------
Function GetFont(ByVal FontName As String,FT_Var as FT_Var) 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
Function FadeText(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), func as sub (inptr() as any ptr, outptr() as any ptr), inptr() as any ptr, outptr() as any ptr,FT_Var as FT_Var) as integer
' Prints text fading in each letter (looks cool, like in Zelda :D)
' Usage: x and y are the coordinates of our text
' Text is the text you want to display including controls. These start with %, followed by the function indicator and eventual parameters.
' There are the following function indicators: ( [+/-] means the sign, [xx] means a hex number (lenght is the number of 'x'))
' character | parameters | function
' n | none | begins a new line
' d | [+/-][xxxx] | sets the difference between the current transparency and the following to +/- xxxx (usually negative values, around -0040)
' s | [+/-][xxxx] | sets the transparency of the current letter to +/- xxxx.
' a | [xx] | sets the step transparency gets increased when text is showed
' t | [xx] | sets the maximum transparency (255 means not transparent, 0 is not visible)
' c | [x][yy] | specifies, how background should be restored. when x=0, it's just deleted (bah :D). yy has no effect
' | | when x=1, the whole text is faded out. yy is the step visibility gets decreased.
' | | when x=2, each glyph gets removed like it's drawn, but reverse. yy has the same effect like
' | | the value specified with <a>
' | | otherwise the text won't be deleted and the background is destroyed.
' X | [xxxx] | sets the right margin of our text
' Y | [xxxx] | sets the maximum y-coordinate. When y wants to get greater than max_y, the output will be truncated at this point.
' x | [+/-][x] | sets the number of pixels added to (current_x_coordinate + lenght_of_current_glyph). Default is 0
' y | [+/-][x] | sets the number of pixels added to (current_y_coordinate + height_of_current_glyph). Default is 0
' any other character| none | this character is displayed (without the previous %). Usually used to display the percent-sign (with %%)
'
' Font is a font loaded with GetFont before.
' Size: right! it's the size of our text (whow, you haven't thought of that, right? :D)
' clr is the color (just use rgb(r,g,b))
' func is the address of a SUB that gets called between text is displayed and text gets deleted. is should receive two arrays of any ptrs, inptr() and outptr().
' inptr() contains pointers to the parameters of this sub, and outptr() contains pointers to the return value(s)
'Return value: in case of an error zero (false), otherwise -1 (true)
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'mytimer_pause 'heh, because otherwise every guy would go on, but we can't see it, and no walls etc are checked... that would result in some trouble...
'#define uglydebug
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 max_x As Integer
Dim max_y As Integer
Dim screen_xlen As Integer
Dim screen_ylen As Integer
Dim screen_depth As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
dim as ubyte endval
Dim delta as Integer
dim clearmode as byte
dim clearparam as ubyte
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))
zx(0)=x
zy(0)=y
endval=255
clearmode=1: clearparam=16
screencontrol fb.GET_SCREEN_SIZE, screen_xlen, screen_ylen
if screen_xlen=0 then
logFATAL ("graphics mode is not initalized! leaving function...")
return 0
end if
screencontrol fb.GET_SCREEN_DEPTH, screen_depth
if screen_depth<> 32 then
logFATAL ("we need 32 bits per pixel! leaving function...")
return 0
end if
'clearparam=255
add=16
transp(0)=0
delta=-4*16
deltax=0:deltay=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
xlog ("parsing string...")
uglylog ("lenght=";len(Text))
j=0
For i = 0 To Len(Text) - 1
'zx(i)=-1
uglylog ("current position:";i;", character='";chr(Text[i]);"', number=";j)
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+1>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("t") then 'endval/maxtransparency-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
endval=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 ";endval;".")
i+=2
elseif Text[i]=asc("X") then 'max_x-wert setzen
i+=1
if i+3>=len(text) then 'actually if i+3>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
max_x=val("&h"+chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parameters from position ";i;" to ";i+3;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parsed them as ";max_x;".")
i+=4
elseif Text[i]=asc("Y") then 'max_y-wert setzen
i+=1
if i+3>=len(text) then 'actually if i+3>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
max_y=val("&h"+chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parameters from position ";i;" to ";i+3;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parsed them as ";max_y;".")
i+=4
elseif Text[i]=asc("x") then 'deltax-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>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 ";deltax;".")
i+=2
elseif Text[i]=asc("y") then 'deltay-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>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 ";deltay;".")
i+=2
elseif Text[i]=asc("c") then 'clearmode incl. parameter
i+=1
if i+2>=len(text) then 'actually if i+1>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
clearmode=val(chr(text[i]))
clearparam=val("&h"+chr(text[i+1],text[i+2]))
uglylog (" parameters from position ";i;" to ";i+2;" are: ";chr(text[i],text[i+1],text[i+2]))
uglylog (" parsed them as ";clearmode;",";clearparam;".")
i+=3
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
if max_x<=x then
logwarn ("max_x was lesser than x at position";i;". set max_x to screen_xlen.")
max_x=screen_xlen
end if
if max_y<=y then
logwarn ("max_y was lesser than y at position";i;". set max_y to screen_ylen.")
max_y=screen_ylen
end if
transp(j+1)=transp(j)+delta
' Load character index
uglylog (" loading character index...")
GlyphIndex = FT_Get_Char_Index(FontFT, Text[i])
' Load character glyph
uglylog (" loading glyph...")
ErrorMsg = FT_Load_Glyph(FontFT, GlyphIndex, FT_LOAD_DEFAULT)
If ErrorMsg Then
logerror("couldn't load glyph! leaving function...")
Return 0
end if
' Render glyph
uglylog (" rendering glyph...")
ErrorMsg = FT_Render_Glyph(FontFT->Glyph, FT_RENDER_MODE_NORMAL)
If ErrorMsg Then
logerror ("wasn't able to render glyph! leaving function...")
Return 0
end if
' Check clipping
If (PenX + FontFT->Glyph->Bitmap_Left + FontFT->Glyph->Bitmap.Width) > max_x Then PenX=X:PenY+=size+deltay'Exit For
If (PenY - FontFT->Glyph->Bitmap_Top + FontFT->Glyph->Bitmap.Rows) > max_y 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
uglylog (" creating buffer for glyph and background...")
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)
uglylog (" getting background...")
'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
uglylog (" drawing glyph into buffer...")
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
uglylog ("done.")
'put (zx(i),zy(i)),zeichen(i),pset
'sleep
else
zeichen(j)=0
zeichenBG(j)=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
xlog ("done.")
if add<1 then
logerror ("add may not be 0! leaving function...")
return 0
end if
dim as double start,s2,timeleft
dim as integer fpscount,itemp,ii,ipressed
itemp=false
do
start=timer
ipressed=false
for ii=0 to 255
if multikey(ii) then ipressed=true : exit for
next
if itemp=false and ipressed=false then itemp=true
if itemp and ipressed then exit do
fpscount+=1 'calculate/show FPS
if timer-s2>=0.25 then
xlog (fpscount*4;" FPS")
xlog ("time left:";timeleft*4;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for i=0 to j-1 'draw background and glyph with alphalevel in transp(i)
if transp(i)+add>=endval and transp(i)<endval then if Zeichen(i) then put (zx(i),zy(i)),Zeichen(i),alpha,endval
transp(i)+=add
if transp (i)>0 and transp(i)<endval then
if ZeichenBG(i) then put (zx(i),zy(i)),ZeichenBG(i),pset:put (zx(i),zy(i)),Zeichen(i),alpha,transp(i)
end if
next
screenunlock
timeleft+=0.02-(timer-start)
do : sleep 1: loop until timer-start>=0.02
loop until transp(j-1)>=255
if ipressed then
for i=0 to j-1 'draw glyph
transp(i)=255
if Zeichen(i) then put (zx(i),zy(i)),Zeichen(i),pset
next
end if
if func then
xlog ("trying to call *func...")
func (inptr(), outptr()) 'now calling our sub...
xlog ("successfully done.")
else
xlog ("func is NULL, not calling.")
end if
xlog ("restoring background...")
select case clearmode
case 1: fpscount=0:timeleft=0:itemp=false
for i=255 to 0 step -clearparam
start=timer
ipressed=false
for ii=0 to 255
if multikey(ii) then ipressed=true : exit for
next
if itemp=false and ipressed=false then itemp=true
if itemp and ipressed then exit for
fpscount+=1
if timer-s2>=0.1 then
xlog (fpscount*10;" FPS")
xlog ("time left:";timeleft*10;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for k=0 to j-1
uglylog ("redrawing background #";k;"...")
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset',alpha,i
uglylog ("painting glyph #";k;" (transparency=";endval/255*i;")")
if Zeichen(k) then put (zx(k),zy(k)),Zeichen(k),alpha,endval/255*i
next
screenunlock
timeleft+=0.02-(timer-start)
do:loop while timer-start<0.02
next
for k=0 to j-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
case 0: screenlock
for k=0 to j-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
screenunlock
case 2: 'for i=1 to j-1
' transp(i)=255
'next
fpscount=0:timeleft=0:itemp=false
do
start=timer
ipressed=false
for ii=0 to 255
if multikey(ii) then ipressed=true : exit for
next
if itemp=false and ipressed=false then itemp=true
if itemp and ipressed then exit do
fpscount+=1
if timer-s2>=0.25 then
xlog (fpscount*4;" FPS")
xlog ("time left:";timeleft*4;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for i=0 to j-1
'if transp(i)>=0 and transp(i)<=clearparam then put (zx(i),zy(i)),ZeichenBG(i),pset
if transp(i)>0 and transp(i)< endval then
uglylog ("restoring background #";i;" (transparency =";transp(i);", x =";zx(i);", y =";zy(i);")...")
if ZeichenBG(i) then put (zx(i),zy(i)),ZeichenBG(i),pset
end if
transp(i)-=clearparam
if transp (i)>0 and transp(i)<endval then
uglylog ("painting glyph #";i;" (transparency =";transp(i);", x =";zx(i);", y =";zy(i);")...")
if Zeichen(i) then put (zx(i),zy(i)),Zeichen(i),alpha,transp(i)
end if
next
screenunlock
timeleft+=0.02-(timer-start)
do : loop until timer-start>=0.02
loop until transp(0)<=0
for k=0 to j-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
end select
xlog ("cleaning up...")
for i=0 to j-1
if Zeichen(i) then
uglylog ("destroying image and background #";i;"...")
imagedestroy Zeichen(i)
imagedestroy ZeichenBG(i)
end if
next
xlog ("done.")
uglylog ("resuming mytimer...")
'mytimer_resume
uglylog ("done.")
'#undef uglydebug
return -1
End Function
sub FTSleep (inptr() as any ptr, outptr() as any ptr)
'This is a sub to use with FadeText to sleep a specified time
'inptr(0) has to be a pointer to an integer containing the amount of msec to sleep
'if this value is positive, you can continue by pressing any key
'if the value is zero, you have to continuse by pressing any key
'if the value is negative, you have to wait the specified time, you cannot interrupt
'outptr(0) has to point to an integer where the pressed key is stored. zero means no
'key was pressed, the sub was exited by timeout
dim as integer sleeptime,i,kint,pressed
dim as double start
logge ("reading sleeptime...")
sleeptime=*cast(integer ptr,inptr(0))
logge (" =";sleeptime)
kint=-1:pressed=0
if sleeptime<0 then sleeptime=abs(sleeptime): kint=0
start=timer
if kint then
do
pressed=0
for i=0 to 255
if multikey (i) then pressed=i: exit for
next
sleep 10
loop while pressed
end if
pressed=0
do
if kint then
for i=0 to 255
if multikey (i) then pressed=i: exit do
next
end if
if sleeptime<>0 then
if timer-start>sleeptime/1000 then exit do
end if
sleep 10
loop
logge ("writing pressed (";pressed;")...")
*cast(integer ptr,outptr(0))=pressed
logge ("done.")
end sub
Function FT_Pos(ByVal x As Integer, ByVal y As Integer, ByVal Text As String, ByVal Font As Integer, ByVal Size As Integer = 14,retval() as integer,FT_Var as FT_Var) as integer
'Usage: x,y,Text,Font,Size are the same as in FadeText
' retval is an integer array where the return values (bottom y and right x of the character) are saved in
' retval(0)=x1, retval(1)=y1, retval(2)=x2, retval(3)=y2 and so on
' to get the middle y of the line, use y-0.3*size
' to get the right x of the character, use the %p after that character, and use x-deltax
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 max_x As Integer
Dim max_y As Integer
Dim screen_xlen As Integer
Dim screen_ylen As Integer
Dim screen_depth As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
dim as ubyte endval
dim as integer retnr,notepos
Dim delta as Integer
dim clearmode as byte
dim clearparam as ubyte
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
endval=255
clearmode=0
screencontrol fb.GET_SCREEN_SIZE, screen_xlen, screen_ylen
if screen_xlen=0 then
logFATAL ("graphics mode is not initalized! leaving function...")
return 0
end if
screencontrol fb.GET_SCREEN_DEPTH, screen_depth
if screen_depth<> 32 then
logFATAL ("we need 32 bits per pixel! leaving function...")
return 0
end if
' 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
retnr=0
logge ("parsing string...")
j=0
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
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
i+=5
elseif Text[i]=asc("a") then 'add-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
i+=2
elseif Text[i]=asc("t") then 'endval/maxtransparency-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
i+=2
elseif Text[i]=asc("X") then 'max_x-wert setzen
i+=1
if i+3>=len(text) then 'actually if i+3>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
max_x=val("&h"+chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parameters from position ";i;" to ";i+3;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parsed them as ";max_x;".")
i+=4
elseif Text[i]=asc("Y") then 'max_y-wert setzen
i+=1
if i+3>=len(text) then 'actually if i+3>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
max_y=val("&h"+chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parameters from position ";i;" to ";i+3;" are: ";chr(text[i],text[i+1],text[i+2],text[i+3]))
uglylog (" parsed them as ";max_y;".")
i+=4
elseif Text[i]=asc("x") then 'deltax-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>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 ";deltax;".")
i+=2
elseif Text[i]=asc("y") then 'deltay-wert setzen
i+=1
if i+1>=len(text) then 'actually if i+1>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 ";deltay;".")
i+=2
elseif Text[i]=asc("c") then 'clearmode incl. parameter
i+=1
if i+2>=len(text) then 'actually if i+1>len(text)-1
logerror ("there are not enough parameters at position";i-2;"! stopping parsing at this point.")
exit for
end if
i+=3
elseif Text[i]=asc("p") then
i+=1
notepos=-1
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
if max_x<=x then
logwarn ("max_x was lesser than x at position";i;". set max_x to screen_xlen.")
max_x=screen_xlen
end if
if max_y<=y then
logwarn ("max_y was lesser than y at position";i;". set max_y to screen_ylen.")
max_y=screen_ylen
end if
' Load character index
uglylog (" loading character index...")
GlyphIndex = FT_Get_Char_Index(FontFT, Text[i])
' Load character glyph
uglylog (" loading glyph...")
ErrorMsg = FT_Load_Glyph(FontFT, GlyphIndex, FT_LOAD_DEFAULT)
If ErrorMsg Then
logerror("couldn't load glyph! leaving function...")
Return 0
end if
' Render glyph
uglylog (" rendering glyph...")
ErrorMsg = FT_Render_Glyph(FontFT->Glyph, FT_RENDER_MODE_NORMAL)
If ErrorMsg Then
logerror ("wasn't able to render glyph! leaving function...")
Return 0
end if
' Check clipping
If (PenX + FontFT->Glyph->Bitmap_Left + FontFT->Glyph->Bitmap.Width) > max_x Then PenX=X:PenY+=size+deltay'Exit For
If (PenY - FontFT->Glyph->Bitmap_Top + FontFT->Glyph->Bitmap.Rows) > max_y Then Exit For
If (PenX + FontFT->Glyph->Bitmap_Left) < 0 Then Exit For
If (PenY - FontFT->Glyph->Bitmap_Top) < 0 Then Exit For
if notepos then
retval(retnr+1)=peny'-size-deltay
retval(retnr)=penx'+FontFT->Glyph->Bitmap_Left
retnr+=2:notepos=0
end if
PenX +=(Slot->Advance.x Shr 6 )+deltax
'line (penx,0)-(penx,599),rgb(255,255,255)
next
return -1
End Function
Function FadeText(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),FT_Var as FT_Var) as integer
dim as any ptr a(0),b(0)
return FadeText (x,y,Text,Font,Size,Clr,0,a(),b(),FT_Var)
end function
sub FadeText_Select (inptr () as any ptr, outptr () as any ptr)
'This is a sub to use with FadeText to wait for a decision between some elements
'inptr(0) has to be a pointer to an integer containing the number of items to choose from
'inptr(1 to number_of_items) have to be pointers to an FT_Select, containing x and y-coordinates
'(top left corner) for the indicator.
'inptr (number_of_items+1) as to be a pointer to an integer containing the preselected item
'outptr(0) has to point to an integer the selection will be stored in
dim as integer wahl, owahl, anzahl,uplock,downlock,raushier
dim as single i,ix,iy,oix,oiy,vx,vy,dx,dy,diff,maxdiff
dim as double start
dim as fb.image ptr BG,symbol
raushier=0
logge ("reading arguments...")
uglylog (" -n...")
anzahl=*cast(integer ptr, inptr(0))
uglylog (" n=";anzahl)
dim as FT_Select item(1 to anzahl)
for i=1 to anzahl
uglylog (" -item(";i;")...")
item(i)=*cast(FT_Select ptr, inptr(i))
uglylog (" item(";i;")=";item(i).x;"/";item(i).y)
next
uglylog (" -current selection...")
wahl=*cast(integer ptr,inptr(anzahl+1))
uglylog (" cs=";wahl)
logge ("done.")
owahl=wahl
logge ("creating background...")
BG=imagecreate (10,10)
symbol=imagecreate(10,10,rgb(255,0,0))
logge ("done.")
logge ("preparing...")
get(item(wahl).x,item(wahl).y)-step (9,9),BG
put (item(wahl).x,item(wahl).y),symbol,trans
ix=item(wahl).x:iy=item(wahl).y
oix=ix:oiy=iy
logge ("done, entering loop")
do
if ix <> oix or iy<> oiy then
screenlock
put (oix,oiy),BG,pset
get (ix,iy)-step(9,9),BG
put (ix,iy),symbol,trans
oix=ix:oiy=iy
screenunlock
end if
if wahl <> owahl then
'ix=item(wahl).x:iy=item(wahl).y
owahl=wahl
maxdiff=sqr((ix-item(wahl).x)^2+(iy-item(wahl).y)^2)/5
uglylog ("choice=";wahl)
end if
if ix<>item(wahl).x or iy<> item(wahl).y then
dx=item(wahl).x-ix:dy=item(wahl).y-iy
diff=sqr(dx^2+dy^2)
if diff >maxdiff then
vx=vx+dx/diff/5
vy=vy+dy/diff/5
if abs(vx) > abs(dx/diff*3) then vx=dx/diff*3
if abs(vy) > abs(dy/diff*3) then vy=dy/diff*3
else
vx=(dx/diff*3)/maxdiff*diff
vy=(dy/diff*3)/maxdiff*diff
end if
if diff <1 then
vx=0:vy=0
ix=item(wahl).x
iy=item(wahl).y
uglylog ("snapped.")
end if
ix=ix+vx:iy=iy+vy
else
if raushier then exit do
end if
if multikey (fb.SC_UP) then
if uplock=0 then
wahl-=1:if wahl<1 then wahl=anzahl
uplock=-1
end if
else
uplock=0
end if
if multikey (fb.SC_DOWN) then
if downlock=0 then
wahl+=1:if wahl>anzahl then wahl=1
downlock=-1
end if
else
downlock=0
end if
if multikey (fb.SC_ENTER) or multikey (fb.SC_SPACE) then raushier=-1
sleep 10
loop
logge ("item no.";wahl;"was selected.")
*cast(integer ptr,outptr(0))=wahl
for i=255 to 128 step -20
screenlock
put (oix,oiy),BG,pset
put (oix,oiy),symbol,alpha,i
screenunlock
sleep 20
next
for i=128 to 255 step 20
screenlock
put (oix,oiy),BG,pset
put (oix,oiy),symbol,alpha,i
screenunlock
sleep 20
next
for i=255 to 0 step -10
screenlock
put (oix,oiy),BG,pset
put (oix,oiy),symbol,alpha,i
screenunlock
sleep 20
next
put (oix,oiy),BG,pset
logge ("cleaning up...")
imagedestroy (BG)
imagedestroy (symbol)
logge ("done.")
end sub
Function FadeInput(ByVal x As Integer, ByVal y As Integer, maxlen as integer, ByVal Font As Integer, ByVal Size As Integer = 14, ByVal Clr As UInteger = Rgb(255, 255, 255),FT_Var as FT_Var) as string
' Allows the user to enter text fading in each letter
' Usage: x and y are the coordinates of our text
' maxlen is the maximal lenght allowed for your text
' Font is a font loaded with GetFont before.
' Size: right! it's the size of our text (whow, you haven't thought of that, right? :D)
' clr is the color (just use rgb(r,g,b))
' clearmode and clearparam (see code) control the behaviour of the program when done with entering text
' clearmode=0 just removes the text (looks ugly :x ). clearmode=1 and 2 fade it out (2 is a bit smoother for the last letter). any other value
' lets the program not remove the text, but destroy the buffer for the background. clearparam behaves like add, but in the opposite direction
'Return value: the text entered by the user (as a string)
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'actually, there's no real difference between clearmodes 1 and 2, but 2 has a smooth fadeout, too, when the last letter hasn't faded in completely
'mytimer_pause 'heh, because otherwise every guy would go on, but we can't see it, and no walls etc are checked... that would result in some trouble...
'#define uglydebug
Dim ErrorMsg As FT_Error
Dim FontFT As FT_Face
Dim GlyphIndex As FT_UInt
Dim Slot As FT_GlyphSlot
Dim PenX (0 to maxlen) As Integer
Dim PenY (0 to maxlen) As Integer
Dim max_x As Integer
Dim max_y As Integer
Dim screen_xlen As Integer
Dim screen_ylen As Integer
Dim screen_depth As Integer
Dim i As Integer
'Dim j As Integer
Dim k As Integer
dim as ubyte endval
Dim delta as Integer
dim clearmode as byte
dim clearparam as ubyte
dim as integer deltax,deltay
Dim add as integer
dim as fb.image ptr zeichen (0 to maxlen-1),zeichenBG(0 to maxlen-1)
dim as integer zx(0 to maxlen-1),zy(0 to maxlen-1)
dim as integer transp(0 to maxlen-1)
dim as integer deltatransp(0 to maxlen-1)
dim as string ink,text
dim as integer nGlyphs
zx(0)=x
zy(0)=y
max_x=700
max_y=500
endval=255
clearmode=2
clearparam=16
screencontrol fb.GET_SCREEN_SIZE, screen_xlen, screen_ylen
if screen_xlen=0 then
logFATAL ("graphics mode is not initalized! leaving function...")
return ""
end if
screencontrol fb.GET_SCREEN_DEPTH, screen_depth
if screen_depth<> 32 then
logFATAL ("we need 32 bits per pixel! leaving function...")
return ""
end if
'clearparam=255
add=16
transp(0)=0
delta=-4*16
deltax=0:deltay=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 ""
Slot = FontFT->Glyph
PenX(0) = x
PenY(0) = y
dim as double start,s2,timeleft
dim as integer fpscount,itemp,ii,ipressed
do
start=timer
fpscount+=1 'calculate/show FPS
if timer-s2>=0.25 then
xlog (fpscount*4;" FPS")
xlog ("time left:";timeleft*4;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for i=0 to len(text)-1 'remove all glyphs
put(zx(i),zy(i)),zeichenBG(i),pset
next
for i=len(text) to nGlyphs-1 'also those that are actually fading out
put(zx(i),zy(i)),zeichenBG(i),pset
next
ink=inkey 'process keyboard input
if ink <> "" then
if ink=chr(13) then
exit do
elseif ink=chr(8) then
if len(text)>0 then
deltatransp (len(text)-1)=-1
text=left(text,len(text)-1)
end if
elseif len(ink)=1 then 'no special chars!
if len(text)<maxlen then
text=text+ink
if deltatransp(len(text)-1)=0 then 'there is no glyph fading out?
nGlyphs=len(text)
deltatransp(len(text)-1)=1
transp(len(text)-1)=0 'and start with zero
elseif deltatransp(len(text)-1)=-1 then 'there is one fading out!
deltatransp(len(text)-1)=1 'fade IN!
'transp(len(text)-1)=0 'and start with zero
'nGlyphs=nGlyphs 'don't change nGlyphs
else 'should never happen!
logWARN ("you should never have come here oO?!")
end if 'transparency settings are done.
' Load character index
uglylog ("loading character index...")
GlyphIndex = FT_Get_Char_Index(FontFT, ink[0])
' Load character glyph
uglylog ("loading glyph...")
ErrorMsg = FT_Load_Glyph(FontFT, GlyphIndex, FT_LOAD_DEFAULT)
If ErrorMsg Then
logerror("couldn't load glyph! leaving function...")
Return ""
end if
' Render glyph
uglylog (" rendering glyph...")
ErrorMsg = FT_Render_Glyph(FontFT->Glyph, FT_RENDER_MODE_NORMAL)
If ErrorMsg Then
logerror ("wasn't able to render glyph! leaving function...")
Return ""
end if
' Check clipping
If (PenX(len(text)-1) + FontFT->Glyph->Bitmap_Left + FontFT->Glyph->Bitmap.Width) > max_x Then PenX(len(text)-1)=X:PenY(len(text)-1)+=size+deltay'Exit For
If (PenY(len(text)-1) - FontFT->Glyph->Bitmap_Top + FontFT->Glyph->Bitmap.Rows) > max_y Then
logERROR ("y was greater than maxy! leaving loop...")
Exit do
end if
If (PenX(len(text)-1) + FontFT->Glyph->Bitmap_Left) < 0 Then
logERROR ("x was less than 0! leaving loop...")
Exit do
end if
If (PenY(len(text)-1) - FontFT->Glyph->Bitmap_Top) < 0 Then
logERROR ("y was less than 0! leaving loop...")
exit do
end if
' 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
uglylog (" creating buffer for glyph and background...")
if zeichen(len(text)-1) then
xlog (" buffer already exists, destroying it...")
imagedestroy(zeichen(len(text)-1))
imagedestroy(zeichenBG(len(text)-1))
xlog (" done.")
end if
zeichen(len(text)-1)=imagecreate(BitmapWid,BitmapHgt)
zeichenBG(len(text)-1)=imagecreate(BitmapWid,BitmapHgt)
zx(len(text)-1)=PenX(len(text)-1) + FontFT->Glyph->Bitmap_Left
zy(len(text)-1)=PenY(len(text)-1) - FontFT->Glyph->Bitmap_Top
BitmapPitch=(zeichen(len(text)-1)->pitch)\4-BitmapWid
'conswrite (BitmapPitch;" , ";zeichen(j)->pitch)
uglylog (" getting background...")
'sleep
get (zx(len(text)-1),zy(len(text)-1))-step (BitmapWid-1,BitmapHgt-1),zeichen(len(text)-1)
get (zx(len(text)-1),zy(len(text)-1))-step (BitmapWid-1,BitmapHgt-1),zeichenBG(len(text)-1)
DestPtr = Cast(UInteger Ptr, zeichen(len(text)-1)+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
uglylog (" drawing glyph into buffer...")
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
uglylog ("done.")
'put (zx(i),zy(i)),zeichen(i),pset
'sleep
else
zeichen(len(text)-1)=0
zeichenBG(len(text)-1)=0
end if
'DrawGlyph FontFT, PenX + FontFT->Glyph->Bitmap_Left, PenY - FontFT->Glyph->Bitmap_Top, Clr
PenX(len(text)) =PenX(len(text)-1)+(Slot->Advance.x Shr 6 )+deltax
PenY(len(text)) =PenY(len(text)-1)
end if
end if
end if
for i=0 to len(text)-1 'draw all glyphs
uglylog ("processing glyph #";i;"...")
if deltatransp(i)>0 then
uglylog ("fading IN...")
transp(i)+=add
if transp(i)>255 then transp(i)=255:deltatransp(i)=0
uglylog ("alpha=";transp(i))
elseif deltatransp(i)<0 then
uglylog ("fading OUT...")
transp(i)-=add
if transp(i)<0 then transp(i)=0:deltatransp(i)=0
uglylog ("alpha=";transp(i))
end if
put(zx(i),zy(i)),zeichen(i),alpha,transp(i)
next
for i=len(text) to nGlyphs-1 'also those that are actually fading out
uglylog ("processing glyph #";i;"...")
if deltatransp(i)>0 then
uglylog ("fading IN...")
transp(i)+=add
if transp(i)>255 then transp(i)=255:deltatransp(i)=0
uglylog ("alpha=";transp(i))
elseif deltatransp(i)<0 then
uglylog ("fading OUT...")
transp(i)-=add
if transp(i)<0 then transp(i)=0:deltatransp(i)=0
uglylog ("alpha=";transp(i))
end if
put(zx(i),zy(i)),zeichen(i),alpha,transp(i)
next
screenunlock
timeleft+=0.02-(timer-start)
do : sleep 1: loop until timer-start>=0.02
loop
screenunlock
xlog ("restoring background...")
select case clearmode
case 1: fpscount=0:timeleft=0:itemp=false
for i=255 to 0 step -clearparam
start=timer
ipressed=false
for ii=0 to 255
if multikey(ii) then ipressed=true : exit for
next
if itemp=false and ipressed=false then itemp=true
if itemp and ipressed then exit for
fpscount+=1
if timer-s2>=0.1 then
xlog (fpscount*10;" FPS")
xlog ("time left:";timeleft*10;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for k=0 to nGlyphs-1
uglylog ("redrawing background #";k;"...")
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset',alpha,i
uglylog ("painting glyph #";k;" (transparency=";endval/255*i;")")
if Zeichen(k) then put (zx(k),zy(k)),Zeichen(k),alpha,endval/255*i
next
screenunlock
timeleft+=0.02-(timer-start)
do:loop while timer-start<0.02
next
for k=0 to nGlyphs-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
case 0: screenlock
for k=0 to nGlyphs-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
screenunlock
case 2: 'for i=1 to j-1
' transp(i)=255
'next
fpscount=0:timeleft=0:itemp=false
do
start=timer
ipressed=false
for ii=0 to 255
if multikey(ii) then ipressed=true : exit for
next
if itemp=false and ipressed=false then itemp=true
if itemp and ipressed then exit do
fpscount+=1
if timer-s2>=0.25 then
xlog (fpscount*4;" FPS")
xlog ("time left:";timeleft*4;" sec per second")
timeleft=0
fpscount=0:s2=timer
end if
screenlock
for i=0 to nGlyphs-1
'if transp(i)>=0 and transp(i)<=clearparam then put (zx(i),zy(i)),ZeichenBG(i),pset
if transp(i)>0 and transp(i)< endval then
uglylog ("restoring background #";i;" (transparency =";transp(i);", x =";zx(i);", y =";zy(i);")...")
if ZeichenBG(i) then put (zx(i),zy(i)),ZeichenBG(i),pset
end if
transp(i)-=clearparam
if transp (i)>0 and transp(i)<endval then
uglylog ("painting glyph #";i;" (transparency =";transp(i);", x =";zx(i);", y =";zy(i);")...")
if Zeichen(i) then put (zx(i),zy(i)),Zeichen(i),alpha,transp(i)
end if
next
screenunlock
timeleft+=0.02-(timer-start)
do : loop until timer-start>=0.02
loop until transp(0)<=0
for k=0 to nGlyphs-1
if ZeichenBG(k) then put (zx(k),zy(k)),ZeichenBG(k),pset
next
end select
xlog ("cleaning up...")
for i=0 to nGlyphs-1
if Zeichen(i) then
uglylog ("destroying image and background #";i;"...")
imagedestroy Zeichen(i)
imagedestroy ZeichenBG(i)
end if
next
xlog ("done.")
uglylog ("resuming mytimer...")
'mytimer_resume
uglylog ("done.")
return text
End Function