Custom FB Fonts
-
- Posts: 1
- Joined: Dec 23, 2021 15:06
Custom FB Fonts
Has anyone created any custom fonts using the native Draw String font system? If so, would you be willing to share one for study and learning purposes?
Re: Custom FB Fonts
I did this a few years ago
For Linux I think line 135 should maybe be screen 0 only
Code: Select all
'============= FONTS SET UP ==========================
Function Filter(Byref tim As Ulong Pointer,_
rad As Single,_
destroy as long=1,_
fade as long=0) As Ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
if fade<0 then fade=0:if fade>100 then fade=100
Type p2
As long x,y
As Ulong col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As long=-ymin To ymax
For x1 As long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
if fade=0 then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
end if
#endmacro
dim as single fd=map(0,100,fade,1,0)
Dim As long _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As long pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As long=0 To (_y)-1
For x As long=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As long ar,ag,ab
Dim As long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As long=0 To _y-1
For x As long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
if destroy then ImageDestroy tim: tim = 0
Function= im
End Function
'basic dos fonts
Sub drawstring(xpos As long,ypos As long,text As String,colour As Ulong,size As Single,im As Any Pointer=0)
Type D2
As Double x,y
As Ulong col
End Type
Static As d2 cpt(),XY()
Static As long runflag
If runflag=0 Then
Redim XY(128,127)
Redim cpt(1 To 64*2)
screen 8
width 640\8,200\16
dim as ulong pointer img
Dim count As long
For ch As long=1 To 127
img=imagecreate(640,200)
Draw String img,(1,1),Chr(ch)
For x As long=1 To 8
For y As long=1 To 16
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<D2>(x,y)
End If
Next y
Next x
count=0
imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As D2 c=Type<D2>(xpos,ypos)
Dim As long dx=xpos,dy=ypos
For z6 As long=1 To Len(text)
Var asci=text[z6-1]
For _x1 As long=1 To 64*2
t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
Else
Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
End If
End If
Next _x1
dx=dx+8
Next z6
End Sub
Sub initfont Constructor 'automatic loader
drawstring(0,0,"",0,0)
SCREEN 0, , , &h80000000
End Sub
function Colour(im as any pointer,newcol as ulong,tweak as long,fontsize as long) as any pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+(_x)*dpp2
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*dpp
(colour)=*pixel
#endmacro
dim as long grade
select case as const fontsize
case 1:grade=200
case 2:grade=225
case 3:grade=200
case 4:grade=190
case 5:grade=165
case else: grade=160
end select
dim as long w,h
Dim As long pitch,pitch2
Dim As Any Pointer row,row2
Dim As Ulong Pointer pixel,pixel2
Dim As Ulong col
dim as long dpp,dpp2
Imageinfo im,w,h,dpp,pitch,row
dim as any pointer temp
temp=imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
for y as long=0 to h-1
for x as long=0 to w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
if v>(grade+tweak) then
ppset2(x,y,newcol)
else
ppset2(x,y,rgb(255,0,255))
end if
next x
next y
return temp
end function
sub CreateFont(byref myfont as any pointer,fontsize as long,col as ulong,tweak as long=0)
Const FIRSTCHAR =32,LASTCHAR=127
Const NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As ubyte Ptr p
dim as any pointer temp
Dim As long i
temp = ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))
myfont=ImageCreate(NUMCHARS*8*FontSize,16*FontSize,rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,chr(i),rgb(255,255,255),FontSize,temp)
Next i
if fontsize<=0 then fontsize=1
if fontsize>1 then
for n as long=0 to fontsize-2
temp=filter(temp,1,1,0)
next n
end if
temp=Colour(temp,col,tweak,fontsize)
put myfont,(0,0),temp,trans
ImageInfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3+i-FIRSTCHAR]=8*FontSize
next i
imagedestroy(temp)
end sub
'=================== END FONT SETUP ========================================
'======================================================================
Function framecounter() As Integer
Var t1=Timer,t2=t1
Static As Double t3,frames,answer
frames=frames+1
If (t2-t3)>=1 Then
t3=t2
answer=frames
frames=0
End If
Return answer
End Function
screen 20,32 'must be 32 bit graohics
color ,rgb(255,100,0)
cls
dim as any pointer font,frame,fin
CreateFont font,4,rgb(0,100,0),0
CreateFont frame,3,rgb(0,100,255),0
CreateFont fin,1,rgb(255,255,255),0
do
screenlock
cls
draw string(200,200),"Timer = " &timer,,font
draw string(30,300),"Framerate = "&framecounter,,frame
draw string(30,500),"Press <esc> to end . . .",,fin
screenunlock
sleep 1
loop until inkey=chr(27)
sleep
-
- Posts: 252
- Joined: Mar 12, 2006 16:25
Re: Custom FB Fonts
Do you mean something like this:
https://www.freebasic-portal.de/porticu ... -1783.html
https://www.freebasic-portal.de/porticu ... -1783.html